4 files changed, 98 insertions, 21 deletions

diff --git a/Presence/ConfigFiles.hs b/Presence/ConfigFiles.hs
index 39442ffd..808e6dd8 100644
--- a/Presence/ConfigFiles.hs
+++ b/Presence/ConfigFiles.hs
@@ -88,9 +88,11 @@ modifyFile (tag,file) user test appending = configPath user file >>= doit
                     return False 
 
 
-modifySolicited = modifyFile ("<? solicited ?>", solicitedFile)
-modifyBuddies   = modifyFile ("<? buddies ?>"  , buddyFile)
-modifyOthers    = modifyFile ("<? others ?>"   , otherFile)
+modifySolicited  = modifyFile ("<? solicited ?>" , solicitedFile)
+modifyBuddies    = modifyFile ("<? buddies ?>"   , buddyFile)
+modifyOthers     = modifyFile ("<? others ?>"    , otherFile)
+modifyPending    = modifyFile ("<? pending ?>"   , pendingFile)
+modifySubscribers = modifyFile ("<? subscribers ?>", subscriberFile)
 
 addBuddy :: User -> ByteString -> IO ()
 addBuddy user buddy =
diff --git a/Presence/XMPP.hs b/Presence/XMPP.hs
index 9190ee3c..173e7cdf 100644
--- a/Presence/XMPP.hs
+++ b/Presence/XMPP.hs
@@ -419,6 +419,7 @@ handleIQGet session cmdChan tag = do
             atomically $ do
                 writeTChan cmdChan InterestedInRoster
                 writeTChan cmdChan . Send $ roster
+            sendPending session
         req -> unhandledGet req
     
 
@@ -502,15 +503,17 @@ toClient session pchan cmdChan rchan = toClient' False False
     let loop = toClient' isBound isInterested
         send xs = yield xs >> prettyPrint ">C: " xs
     event <- liftIO . atomically $ 
-              foldr1 orElse [fmap PChan   $ readTChan pchan
+              foldr1 orElse [fmap CmdChan $ readTChan cmdChan
                             ,fmap RChan   $ readTChan rchan
-                            ,fmap CmdChan $ readTChan cmdChan
+                            ,fmap PChan   $ readTChan pchan
                             ]
     case event of
       CmdChan QuitThread -> return ()
       CmdChan (Send xs)  -> send xs >> loop
       CmdChan BoundToResource    -> toClient' True    isInterested
-      CmdChan InterestedInRoster -> toClient' isBound True
+      CmdChan InterestedInRoster -> do
+        liftIO . putStrLn $ "Roster: interested"
+        toClient' isBound True
       -- CmdChan cmd        -> liftIO (putStrLn $ "unhandled event: "++show cmd) >> loop
       RChan   (RequestedSubscription who contact) ->  do
         jid <- liftIO $ getJID session
@@ -520,11 +523,15 @@ toClient session pchan cmdChan rchan = toClient' False False
         loop
       RChan   (NewBuddy who contact) ->  do
         liftIO . putStrLn $ "Roster push: NewBuddy "++show (isInterested,who,contact)
-        jid <- liftIO $ getJID session
+        (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"   (L.show jid)
+                    , attrbs "to"   me
                     , attr   "type" "subscribed"
                     ]
                  , EventEndElement "{jabber:client}presence" ]
@@ -537,12 +544,28 @@ toClient session pchan cmdChan rchan = toClient' False False
                                      [attr "subscription" subscription]
             send r
         loop
+      RChan   (PendingBuddy who contact) ->  do
+        liftIO . putStrLn $ "Roster: Pending buddy "++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" "subscribe"
+                    ]
+                 , EventEndElement "{jabber:client}presence" ]
+        loop
       PChan presence   -> do 
         when isBound $ do
             xs <- liftIO $ xmlifyPresenceForClient presence
             send xs
         loop
 
+
 handleClient
   :: (SocketLike sock, HHead l (XMPPClass session),
       JabberClientSession session) =>
@@ -805,21 +828,12 @@ peerRequestsSubsription session stanza = do
              ps <- userStatus session user
              mapM_ (announcePresence session) ps
       else
-        -- TODO
-        -- if no client:
-        --   add pending
-        -- else:
-        --   notify client(s)
-        return ()
-    return ()
+        liftIO $ processRequest session user fromjid
 
 clientApprovesSubscription session stanza = do
     liftIO $ putStrLn $ "CLIENT APPROVES SUBSCRIPTION"
-    -- add subscribers
-    -- remove pending
-    -- remove others
-    -- notify peer
-    return ()
+    withJust (lookupAttrib "to" (tagAttrs stanza)) $ \to_str -> do
+    liftIO $ approveSubscriber session (textToByteString to_str)
 
 peerApprovesSubscription session stanza = do
     liftIO $ putStrLn $ "PEER APPROVES SUBSCRIPTION"
diff --git a/Presence/XMPPTypes.hs b/Presence/XMPPTypes.hs
index e05d0782..6d00d509 100644
--- a/Presence/XMPPTypes.hs
+++ b/Presence/XMPPTypes.hs
@@ -38,6 +38,7 @@ import ByteStringOperators
 import SocketLike
 import GetHostByAddr
 import Data.Maybe (listToMaybe,catMaybes)
+import Control.Monad.STM
 
 class JabberClientSession session where
     data XMPPClass session
@@ -48,6 +49,7 @@ class JabberClientSession session where
     subscribe :: session -> Maybe JID -> IO (TChan Presence)
     subscribeToRoster :: session -> IO (TChan RosterEvent)
     forCachedPresence :: session -> (Presence -> IO ()) -> IO ()
+    sendPending :: session -> IO ()
     getMyBuddies       :: session -> IO [ByteString]
     getMySubscribers   :: session -> IO [ByteString]
     getMyOthers        :: session -> IO [ByteString]
@@ -55,6 +57,7 @@ class JabberClientSession session where
     getMySolicited     :: session -> IO [ByteString]
     addSolicited :: session -> ByteString -> JID ->  IO ()
     isSubscribed :: session -> ByteString -> IO Bool
+    approveSubscriber :: session -> ByteString -> IO ()
 
 class JabberPeerSession session where
     data XMPPPeerClass session
@@ -68,6 +71,7 @@ class JabberPeerSession session where
     getBuddies       :: XMPPPeerClass session -> ByteString -> IO [ByteString]
     getSubscribers   :: XMPPPeerClass session -> ByteString -> IO [ByteString]
     processApproval  :: session -> ByteString -> JID -> IO ()
+    processRequest   :: session -> ByteString -> JID -> IO ()
 
 -- | Jabber ID (JID) datatype
 data JID = JID { name :: Maybe ByteString
@@ -90,6 +94,9 @@ data RosterEvent = RequestedSubscription
                  | NewBuddy 
                     {- user: -} ByteString
                     {- contact: -} ByteString
+                 | PendingBuddy
+                    {- user: -} ByteString
+                    {- contact: -} ByteString
  deriving Prelude.Show
 
 data Peer = LocalHost | RemotePeer SockAddr
diff --git a/Presence/main.hs b/Presence/main.hs
index eab02e88..5cccffea 100644
--- a/Presence/main.hs
+++ b/Presence/main.hs
@@ -207,6 +207,23 @@ instance JabberClientSession ClientSession where
             L.putStrLn $ "cached presence: " <++> bshow p
             action p
 
+    sendPending s = do
+        jid <- getJID s 
+        putStrLn $ "sendPending "<++> bshow jid
+        flip (maybe (return ())) (name jid) $ \user -> do
+        pending <- ConfigFiles.getPending user
+        let getRChan = do
+                let rchan = rosterChannel . presence_state $ s
+                isempty <- isEmptyTMVar rchan
+                if (not isempty) 
+                 then do
+                    (_,ch) <- readTMVar rchan
+                    return . Just $ ch
+                 else return Nothing
+        atomically $ do
+            whenJust getRChan $ \rchan -> do
+            forM_ pending (writeTChan rchan . PendingBuddy user)
+
     addSolicited s jid_str jid = do
         me <- getJID s
         withJust (name me) $ \user -> do
@@ -247,6 +264,21 @@ instance JabberClientSession ClientSession where
         msubs <- mapM (cmpJID cjid) subs
         return (Nothing `elem` msubs)
 
+    approveSubscriber s contact = do
+        user <- readIORef (unix_uid s) >>= getJabberUserForId
+        cjid <- parseHostNameJID contact
+        let rmjid modify user buddy = modify user (cmpJID buddy) Nothing
+        addRawJid ConfigFiles.modifySubscribers user contact -- add subscribers
+        rmjid ConfigFiles.modifyPending user cjid
+        rmjid ConfigFiles.modifyOthers  user cjid
+        -- TODO
+        -- roster push (to other clients, or do we include the approver?)
+        sendMessage (outGoingConnections . presence_state $ s) 
+                    (Approval (JID (Just user) LocalHost Nothing) 
+                              cjid)
+                    (peer cjid)
+
+
 tupleToJID (user,tty,pid) = jid user LocalHost tty
 
 data PeerSession = PeerSession {
@@ -330,7 +362,29 @@ instance JabberPeerSession PeerSession where
             (_,ch) <- readTMVar rchan
             writeTChan ch (NewBuddy user buddy)
         return ()
-        
+    processRequest session user buddy = do
+        let addjid modify user buddy = do
+                hbuddy <- asHostNameJID buddy
+                modify user (cmpJID buddy) hbuddy
+        was_pending <- addjid ConfigFiles.modifyPending user buddy
+        putStrLn $ "processRequest was_pending="<++>bshow was_pending
+        --    "all available resources in accordence with section 8"
+        --    Section 8 says (for presence of type "subscribe", the server MUST
+        --    adhere to the rules defined under Section 3 and summarized under
+        --    Appendix A. 
+        --    Appendex A.3.1 says
+        --      contact ∈ subscribers --> SHOULD NOT, already handled
+        --      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 (PendingBuddy user buddy)
 
 
 data RefCountedChan = forall a. RefCountedChan (TMVar (RefCount,TChan a))