1 files changed, 79 insertions, 13 deletions

diff --git a/Presence/XMPP.hs b/Presence/XMPP.hs
index 7d69e126..c2ae2fe2 100644
--- a/Presence/XMPP.hs
+++ b/Presence/XMPP.hs
@@ -457,6 +457,8 @@ fromClient session cmdChan = doNestingXML $ do
                                            -> clientRequestsSubscription session cmdChan stanza
              _ | stanza `isClientPresenceOf` presenceTypeSubscribed
                                            -> clientApprovesSubscription session stanza
+             _ | stanza `isClientPresenceOf` presenceTypeUnsubscribed
+                                           -> clientRejectsSubscription session stanza
              _ | otherwise                 -> unhandledStanza
 
             awaitCloser stanza_lvl
@@ -544,6 +546,29 @@ toClient session pchan cmdChan rchan = toClient' False False
                                      [attr "subscription" subscription]
             send r
         loop
+      RChan   (RemovedBuddy who contact) ->  do
+        liftIO . putStrLn $ "Roster push: RemovedBuddy "++show (isInterested,who,contact)
+        (jid,me) <- liftIO $ do
+                        jid <- getJID session
+                        me <- asHostNameJID jid
+                        return (jid,me)
+        withJust me $ \me -> do
+        when (isInterested && Just who==name jid) $ do
+            send [ EventBeginElement "{jabber:client}presence" 
+                    [ attrbs "from" contact
+                    , attrbs "to"   me
+                    , attr   "type" "unsubscribed"
+                    ]
+                 , EventEndElement "{jabber:client}presence" ]
+            let f True  = "from"
+                f False = "none"
+            subscription <- fmap f (liftIO $ isSubscribed session contact)
+            r <- liftIO . handleIO (\e -> putStrLn ("Roster RemovedBuddy error: "++show e) >> return []) $ do
+                            rosterPush jid 
+                                     (toStrict . L.decodeUtf8 $ contact) 
+                                     [attr "subscription" subscription]
+            send r
+        loop
       RChan   (NewSubscriber who contact) ->  do
         liftIO . putStrLn $ "Roster push: NewSubscriber "++show (isInterested,who,contact)
         (jid,me) <- liftIO $ do
@@ -561,6 +586,23 @@ toClient session pchan cmdChan rchan = toClient' False False
                                      [attr "subscription" subscription]
             send r
         loop
+      RChan   (RejectSubscriber who contact) ->  do
+        liftIO . putStrLn $ "Roster push: RejectSubscriber "++show (isInterested,who,contact)
+        (jid,me) <- liftIO $ do
+                        jid <- getJID session
+                        me <- asHostNameJID jid
+                        return (jid,me)
+        withJust me $ \me -> do
+        when (isInterested && Just who==name jid) $ do
+            let f True  = "to"
+                f False = "none"
+            subscription <- fmap f (liftIO $ isBuddy session contact)
+            r <- liftIO . handleIO (\e -> putStrLn ("Roster RejectSubscriber error: "++show e) >> return []) $ do
+                            rosterPush jid 
+                                     (toStrict . L.decodeUtf8 $ contact) 
+                                     [attr "subscription" subscription]
+            send r
+        loop
       RChan   (PendingSubscriber who contact) ->  do
         liftIO . putStrLn $ "Roster: Pending buddy "++show (isInterested,who,contact)
         (jid,me) <- liftIO $ do
@@ -709,11 +751,12 @@ matchAttribMaybe name Nothing attrs
     | otherwise
     = False
 
-presenceTypeOffline = Just "unavailable"
-presenceTypeOnline  = Nothing
-presenceTypeProbe   = Just "probe"
-presenceTypeSubscribe = Just "subscribe"
-presenceTypeSubscribed = Just "subscribed"
+presenceTypeOffline      = Just "unavailable"
+presenceTypeOnline       = Nothing
+presenceTypeProbe        = Just "probe"
+presenceTypeSubscribe    = Just "subscribe"
+presenceTypeSubscribed   = Just "subscribed"
+presenceTypeUnsubscribed = Just "unsubscribed"
 
 isPresenceOf (EventBeginElement name attrs) testType
     | name=="{jabber:server}presence"
@@ -854,6 +897,11 @@ clientApprovesSubscription session stanza = do
     withJust (lookupAttrib "to" (tagAttrs stanza)) $ \to_str -> do
     liftIO $ approveSubscriber session (textToByteString to_str)
 
+clientRejectsSubscription session stanza = do
+    liftIO $ putStrLn $ "CLIENT REJECTS SUBSCRIPTION"
+    withJust (lookupAttrib "to" (tagAttrs stanza)) $ \to_str -> do
+    liftIO $ rejectSubscriber session (textToByteString to_str)
+
 peerApprovesSubscription session stanza = do
     liftIO $ putStrLn $ "PEER APPROVES SUBSCRIPTION"
     whenJust (liftIO . handleIO (\e -> putStrLn ("peerApprovesSubscription: "++show e) >> return Nothing) 
@@ -861,6 +909,13 @@ peerApprovesSubscription session stanza = do
     withJust (name tojid) $ \user -> do
     liftIO $ processApproval session user fromjid
 
+peerRejectsSubscription session stanza = do
+    liftIO $ putStrLn $ "PEER REJECTS SUBSCRIPTION"
+    whenJust (liftIO . handleIO (\e -> putStrLn ("peerRejectsSubscription: "++show e) >> return Nothing) 
+             $ stanzaFromTo session stanza) $ \(fromjid,tojid) -> do
+    withJust (name tojid) $ \user -> do
+    liftIO $ processRejection session user fromjid
+
 fromPeer :: (MonadThrow m,MonadIO m, JabberPeerSession session) => 
     session -> Sink XML.Event m ()
 fromPeer session = doNestingXML $ do
@@ -891,6 +946,8 @@ fromPeer session = doNestingXML $ do
                     -> peerRequestsSubsription session stanza
               _ | stanza `isPresenceOf` presenceTypeSubscribed
                     -> peerApprovesSubscription session stanza
+              _ | stanza `isPresenceOf` presenceTypeUnsubscribed
+                    -> peerRejectsSubscription session stanza
               _ -> unhandledStanza
 
             awaitCloser stanza_lvl
@@ -908,7 +965,7 @@ newServerConnections = newTVar Map.empty
 data CachedMessages = CachedMessages 
     { presences :: Map JID JabberShow
     , probes :: Map JID (Set (Bool,JID)) -- False means solicitation rather than probe
-    , approvals :: Map JID (Set JID) 
+    , approvals :: Map JID (Set (Bool,JID) ) -- False means rejection rather than approval
     }
 newCache = CachedMessages Map.empty Map.empty Map.empty
 
@@ -938,7 +995,11 @@ connect_to_server chan peer = (>> return ()) . runMaybeT $ do
                     writeIORef cached (cache { probes=probes' })
         cacheCmd (Approval from to) cached = do
                     cache <- readIORef cached
-                    let approvals' = mmInsert from to $ approvals cache
+                    let approvals' = mmInsert (True,from) to $ approvals cache
+                    writeIORef cached (cache { approvals=approvals' })
+        cacheCmd (Rejection from to) cached = do
+                    cache <- readIORef cached
+                    let approvals' = mmInsert (False,from) to $ approvals cache
                     writeIORef cached (cache { approvals=approvals' })
 
     fix $ \sendmsgs -> do
@@ -1038,16 +1099,18 @@ toPeer sock cache chan fail = do
         sendSolicitation from to = 
             sendOrFail (presenceStanza sock from to "subscribe")
                        (Solicitation from to)
-        sendApproval from to = 
-            sendOrFail (presenceStanza sock from to "subscribed")
-                       (Approval from to)
+        sendApproval approve from to = 
+            sendOrFail (presenceStanza sock from to 
+                          (if approve then "subscribed" else "unsubscribed"))
+                       (if approve then Approval from to
+                                   else Rejection from to)
 
 
     send greetPeer
     forM_ (Map.assocs . approvals $ cache) $ \(to,froms) -> do
-        forM_ (Set.toList froms) $ \from -> do
+        forM_ (Set.toList froms) $ \(approve,from) -> do
             liftIO $ L.putStrLn "sending cached approval..."
-            sendApproval from to
+            sendApproval approve from to
     forM_ (Map.assocs . presences $ cache) $ \(jid,st) -> do
         sendPresence (Presence jid st)
     forM_ (Map.assocs . probes $ cache) $ \(to,froms) -> do
@@ -1073,7 +1136,10 @@ toPeer sock cache chan fail = do
             sendSolicitation from to
           Approval from to -> do
             liftIO . L.putStrLn $ "sending approval "<++>bshow (from,to)
-            sendApproval from to
+            sendApproval True from to
+          Rejection from to -> do
+            liftIO . L.putStrLn $ "sending rejection "<++>bshow (from,to)
+            sendApproval False from to
         loop
     send goodbyePeer