Handle rejection case.

3 files changed, 144 insertions, 40 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
 
diff --git a/Presence/XMPPTypes.hs b/Presence/XMPPTypes.hs
index 0e98a77b..4507f5bf 100644
--- a/Presence/XMPPTypes.hs
+++ b/Presence/XMPPTypes.hs
@@ -59,6 +59,7 @@ class JabberClientSession session where
     isSubscribed :: session -> ByteString -> IO Bool
     isBuddy      :: session -> ByteString -> IO Bool
     approveSubscriber :: session -> ByteString -> IO ()
+    rejectSubscriber  :: session -> ByteString -> IO ()
 
 class JabberPeerSession session where
     data XMPPPeerClass session
@@ -72,6 +73,7 @@ class JabberPeerSession session where
     getBuddies       :: XMPPPeerClass session -> ByteString -> IO [ByteString]
     getSubscribers   :: XMPPPeerClass session -> ByteString -> IO [ByteString]
     processApproval  :: session -> ByteString -> JID -> IO ()
+    processRejection :: session -> ByteString -> JID -> IO ()
     processRequest   :: session -> ByteString -> JID -> IO ()
 
 -- | Jabber ID (JID) datatype
@@ -95,12 +97,18 @@ data RosterEvent = RequestedSubscription
                  | NewBuddy 
                     {- user: -} ByteString
                     {- contact: -} ByteString
+                 | RemovedBuddy 
+                    {- user: -} ByteString
+                    {- contact: -} ByteString
                  | PendingSubscriber
                     {- user: -} ByteString
                     {- contact: -} ByteString
                  | NewSubscriber 
                     {- user: -} ByteString
                     {- contact: -} ByteString
+                 | RejectSubscriber 
+                    {- user: -} ByteString
+                    {- contact: -} ByteString
  deriving Prelude.Show
 
 data Peer = LocalHost | RemotePeer SockAddr
@@ -220,6 +228,7 @@ data OutBoundMessage = OutBoundPresence Presence
                         | PresenceProbe JID JID
                         | Solicitation  JID JID
                         | Approval JID JID
+                        | Rejection JID JID
  deriving Prelude.Show
 
 getNamesForPeer :: Peer -> IO [S.ByteString]
diff --git a/Presence/main.hs b/Presence/main.hs
index 702b98d5..781b87fa 100644
--- a/Presence/main.hs
+++ b/Presence/main.hs
@@ -87,6 +87,14 @@ data PresenceState = PresenceState
     }
 
 
+rosterPush msg state = do
+        let rchan = rosterChannel state
+        atomically $ do
+            isempty <- isEmptyTMVar rchan
+            when (not isempty) $ do
+            (_,ch) <- readTMVar rchan
+            writeTChan ch msg
+
 getJabberUserForId muid =
              maybe (return "nobody") 
                    (\(uid,_) -> 
@@ -157,7 +165,7 @@ instance JabberClientSession ClientSession where
 
         rsc <- readIORef (unix_resource s)
         -- let jid = user <++> "@" <++> host <++?> "/" <++$> rsc
-        L.putStrLn $ "CLIENT SESSION: jid " <++> L.show (JID (Just user) host rsc)
+        -- L.putStrLn $ "CLIENT SESSION: jid " <++> L.show (JID (Just user) host rsc)
         return (JID (Just user) host rsc)
 
     closeSession session  = do
@@ -228,12 +236,9 @@ instance JabberClientSession ClientSession where
         me <- getJID s
         withJust (name me) $ \user -> do
         addRawJid ConfigFiles.modifySolicited user jid_str
-        let rchan = rosterChannel . presence_state $ s
-        atomically $ do
-            isempty <- isEmptyTMVar rchan
-            when (not isempty) $ do
-            (_,ch) <- readTMVar rchan
-            writeTChan ch (RequestedSubscription user jid_str)
+
+        rosterPush (RequestedSubscription user jid_str) (presence_state s)
+
         sendMessage (outGoingConnections . presence_state $ s) 
                     (Solicitation me jid)
                     (peer jid)
@@ -278,17 +283,14 @@ instance JabberClientSession ClientSession where
         user <- readIORef (unix_uid s) >>= getJabberUserForId
         cjid <- parseHostNameJID contact
         let rmjid modify user buddy = modify user (cmpJID buddy) Nothing
+
+        -- update config files
         addRawJid ConfigFiles.modifySubscribers user contact -- add subscribers
         rmjid ConfigFiles.modifyPending user cjid
         rmjid ConfigFiles.modifyOthers  user cjid
         
         -- roster push
-        let rchan = rosterChannel . presence_state $ s
-        atomically $ do
-            isempty <- isEmptyTMVar rchan
-            when (not isempty) $ do
-            (_,ch) <- readTMVar rchan
-            writeTChan ch (NewSubscriber user contact)
+        rosterPush (NewSubscriber user contact) (presence_state s)
 
         -- notify peer
         sendMessage (outGoingConnections . presence_state $ s) 
@@ -300,6 +302,33 @@ instance JabberClientSession ClientSession where
         forM_ presence $ \p -> sendMessage cons (OutBoundPresence p) (peer cjid)
         return ()
 
+    rejectSubscriber s contact = do
+        user <- readIORef (unix_uid s) >>= getJabberUserForId
+        cjid <- parseHostNameJID contact
+        let rmjid modify user buddy = modify user (cmpJID buddy) Nothing
+        
+        -- update config files
+        was_pending    <- rmjid ConfigFiles.modifyPending user cjid
+        was_subscribed <- rmjid ConfigFiles.modifySubscribers user cjid
+        addRawJid ConfigFiles.modifyOthers user contact
+        
+        -- roster push
+        rosterPush (RejectSubscriber user contact) (presence_state s)
+
+        -- notify peer
+        when (was_pending || was_subscribed) $ do
+        let cons = outGoingConnections . presence_state $ s
+            isonline (Presence _ Offline) = False
+            isonline _                    = True
+        presence <- fmap (filter isonline) $ getUserStatus (presence_state s) user
+        me <- getJID s
+        when (not (null presence)) $
+            sendMessage cons (OutBoundPresence . Presence me $ Offline) (peer cjid)
+        sendMessage (outGoingConnections . presence_state $ s) 
+                    (Rejection (JID (Just user) LocalHost Nothing) 
+                              cjid)
+                    (peer cjid)
+        return ()
 
 tupleToJID (user,tty,pid) = jid user LocalHost tty
 
@@ -375,19 +404,24 @@ instance JabberPeerSession PeerSession where
         solicited <- ConfigFiles.getSolicited user
         let rmjid modify user buddy = modify user (cmpJID buddy) Nothing
         was_sol <- rmjid ConfigFiles.modifySolicited user buddy
-        putStrLn $ "was_sol = "<++>bshow was_sol
         when was_sol $ do -- if buddy ∈ solicited:
         addJid ConfigFiles.modifyBuddies user buddy --   add buddies
         rmjid ConfigFiles.modifyOthers user buddy --   remove others
-        let rchan = rosterChannel . peer_global $ session
         mbuddy <- asHostNameJID buddy
         withJust mbuddy $ \buddy -> do
-        atomically $ do
-            isempty <- isEmptyTMVar rchan
-            when (not isempty) $ do
-            (_,ch) <- readTMVar rchan
-            writeTChan ch (NewBuddy user buddy)
-        return ()
+        rosterPush (NewBuddy user buddy) (peer_global session)
+
+    processRejection session user buddy = do
+        solicited <- ConfigFiles.getSolicited user
+        let rmjid modify user buddy = modify user (cmpJID buddy) Nothing
+        was_sol <- rmjid ConfigFiles.modifySolicited user buddy
+        when was_sol $ do -- if buddy ∈ solicited:
+        rmjid ConfigFiles.modifyBuddies user buddy -- remove buddies
+        addJid ConfigFiles.modifyOthers user buddy -- add others
+        mbuddy <- asHostNameJID buddy
+        withJust mbuddy $ \buddy -> do
+        rosterPush (RemovedBuddy user buddy) (peer_global session)
+
     processRequest session user buddy = do
         let addjid modify user buddy = do
                 hbuddy <- asHostNameJID buddy
@@ -403,14 +437,9 @@ instance JabberPeerSession PeerSession where
         --      contact ∉ subscribers & contact ∈ pending --> SHOULD NOT
         --      contact ∉ subscribers & contact ∉ pending --> MUST
         when (not was_pending) $ do
-        let rchan = rosterChannel . peer_global $ session
         mbuddy <- asHostNameJID buddy
         withJust mbuddy $ \buddy -> do
-        atomically $ do
-            isempty <- isEmptyTMVar rchan
-            when (not isempty) $ do
-            (_,ch) <- readTMVar rchan
-            writeTChan ch (PendingSubscriber user buddy)
+        rosterPush (PendingSubscriber user buddy) (peer_global session)
 
 
 data RefCountedChan = forall a. RefCountedChan (TMVar (RefCount,TChan a))