Send roster push events to client in case of subscription requests.

3 files changed, 100 insertions, 15 deletions

diff --git a/Presence/XMPP.hs b/Presence/XMPP.hs
index 1520839e..a08c1a0e 100644
--- a/Presence/XMPP.hs
+++ b/Presence/XMPP.hs
@@ -470,19 +470,59 @@ prettyPrint prefix xs =
     liftIO $ do
         CL.sourceList xs $= renderBytes (def { rsPretty=True }) =$= CB.lines $$ CL.mapM_ (S.putStrLn . (prefix `S.append`))
 
-toClient :: MonadIO m => TChan Presence -> TChan Commands -> Source m [XML.Event]
-toClient pchan cmdChan = fix $ \loop -> do
-    let send xs = yield xs >> prettyPrint ">C: " xs
+
+rosterPush to contact attrs = do
+    let n   = name to
+        rsc = resource to
+    names <- getNamesForPeer (peer to)
+    let tostr p = L.decodeUtf8 $ n <$++> "@" <?++> L.fromChunks [p] <++?>  "/" <++$> rsc
+        jidstrs = fmap (toStrict . tostr) names
+        tojid = head jidstrs
+    return
+      [ EventBeginElement "{jabber:client}iq" 
+            [ attr "to"   tojid
+            , attr "id"   "someid"
+            , attr "type" "set"
+            ]
+      , EventBeginElement "{jabber:iq:roster}query" []
+      , EventBeginElement "{jabber:iq:roster}item" (attr "jid" contact : attrs)
+      , EventEndElement   "{jabber:iq:roster}item"
+      , EventEndElement   "{jabber:iq:roster}query"
+      , EventEndElement "{jabber:client}iq"
+      ]
+
+data EventsForClient = CmdChan Commands 
+                     | PChan   Presence
+                     | RChan   RosterEvent
+
+toClient :: (MonadIO m, JabberClientSession session ) => 
+    session -> TChan Presence -> TChan Commands -> TChan RosterEvent -> Source m [XML.Event]
+toClient session pchan cmdChan rchan = toClient' False False 
+ where
+  toClient' isBound isInterested = do
+    let loop = toClient' isBound isInterested
+        send xs = yield xs >> prettyPrint ">C: " xs
     event <- liftIO . atomically $ 
-              orElse (fmap Left  $ readTChan pchan)
-                     (fmap Right $ readTChan cmdChan)
+              foldr1 orElse [fmap PChan   $ readTChan pchan
+                            ,fmap RChan   $ readTChan rchan
+                            ,fmap CmdChan $ readTChan cmdChan
+                            ]
     case event of
-      Right QuitThread -> return ()
-      Right (Send xs)  -> send xs >> loop
-      Right cmd        -> liftIO (putStrLn $ "unhandled event: "++show cmd) >> loop
-      Left  presence   -> do 
-        xs <- liftIO $ xmlifyPresenceForClient presence
-        send xs
+      CmdChan QuitThread -> return ()
+      CmdChan (Send xs)  -> send xs >> loop
+      CmdChan BoundToResource    -> toClient' True    isInterested
+      CmdChan InterestedInRoster -> toClient' isBound True
+      CmdChan cmd        -> liftIO (putStrLn $ "unhandled event: "++show cmd) >> loop
+      RChan   (RequestedSubscription who contact) ->  do
+        jid <- liftIO $ getJID session
+        when (isInterested && Just who==name jid) $ do
+            r <- liftIO $ rosterPush jid (toStrict . L.decodeUtf8 $ contact) [attr "ask" "subscribe"]
+            send r
+        loop
+      PChan presence   -> do 
+        when isBound $ do
+            xs <- liftIO $ xmlifyPresenceForClient presence
+            send xs
         loop
 
 handleClient
@@ -496,10 +536,11 @@ handleClient st src snk = do
     session <- newSession session_factory sock
     Prelude.putStrLn $ "PEER NAME: "++Prelude.show pname
     pchan <- subscribe session Nothing
+    rchan <- subscribeToRoster session
     cmdChan <- atomically newTChan
 
 #ifdef RENDERFLUSH
-    writer <- async (   toClient pchan cmdChan 
+    writer <- async (   toClient session pchan cmdChan rchan
                     $$  flushList
                     =$= renderBuilderFlush def 
                     =$= builderToByteStringFlush 
@@ -695,6 +736,8 @@ clientRequestsSubscription session cmdChan stanza = do
             addSolicited session (L.fromChunks [S.encodeUtf8 to_str]) -- jid
             putStrLn $ "added to solicited: " ++ show to_jid
             -- TODO: create roster item and push to interested clients
+            -- addSolicited should write event to a roster channel
+            -- that toClient will be listening on.
     return ()
 
 peerRequestsSubsription session stanza = do
diff --git a/Presence/XMPPTypes.hs b/Presence/XMPPTypes.hs
index 301f19fd..2bba8614 100644
--- a/Presence/XMPPTypes.hs
+++ b/Presence/XMPPTypes.hs
@@ -38,6 +38,7 @@ class JabberClientSession session where
     getJID       :: session -> IO JID
     closeSession :: session -> IO ()
     subscribe :: session -> Maybe JID -> IO (TChan Presence)
+    subscribeToRoster :: session -> IO (TChan RosterEvent)
     forCachedPresence :: session -> (Presence -> IO ()) -> IO ()
     getMyBuddies       :: session -> IO [ByteString]
     getMySubscribers   :: session -> IO [ByteString]
@@ -72,6 +73,11 @@ data JabberShow = Offline
 data Presence = Presence JID JabberShow
  deriving Prelude.Show
 
+data RosterEvent = RequestedSubscription 
+                    {- user: -} ByteString 
+                    {- contact: -} ByteString
+ deriving Prelude.Show
+
 data Peer = LocalHost | RemotePeer SockAddr
   deriving (Eq,Prelude.Show)
 
diff --git a/Presence/main.hs b/Presence/main.hs
index bf4809a8..a7ff5e5a 100644
--- a/Presence/main.hs
+++ b/Presence/main.hs
@@ -1,6 +1,7 @@
 {-# LANGUAGE CPP               #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE TypeFamilies      #-}
+{-# LANGUAGE ExistentialQuantification #-}
 module Main where
 
 import System.Directory
@@ -79,6 +80,7 @@ data PresenceState = PresenceState
     , subscriberMap :: TVar (Map JID (RefCount,TChan Presence)) -- UNUSED as yet
     , localSubscriber :: TMVar (RefCount,TChan Presence) -- TODO: rename this, its not just locals
                                                          -- ... or make a seperate channel for remotes
+    , rosterChannel :: TMVar (RefCount,TChan RosterEvent)
     , remoteUsers :: TVar (Map Peer (RefCount,TVar (MultiMap JabberUser (JabberResource,JabberShow))))
     , outGoingConnections :: TVar (Map Peer (TChan OutBoundMessage, ThreadId)) 
     }
@@ -99,6 +101,7 @@ data ClientSession = ClientSession {
     localhost :: Peer, -- ByteString,
     unix_uid :: (IORef (Maybe (UserID,L.ByteString))),
     unix_resource :: (IORef (Maybe L.ByteString)),
+    chans :: TVar [RefCountedChan],
     presence_state :: PresenceState
 }
 
@@ -112,7 +115,8 @@ instance JabberClientSession ClientSession where
         L.putStrLn $ "CLIENT SESSION: open " <++> bshow muid
         uid_ref <- newIORef muid
         res_ref <- newIORef Nothing
-        return $ ClientSession (hostname state) uid_ref res_ref state
+        chans <- atomically $ newTVar []
+        return $ ClientSession (hostname state) uid_ref res_ref chans state
 
     setResource  s  resource    = do
         -- TODO: handle resource = empty string 
@@ -137,15 +141,30 @@ instance JabberClientSession ClientSession where
         return (JID (Just user) host rsc)
 
     closeSession session  = do
+        atomically $ do
+            cs <- readTVar (chans session)
+            forM_ cs $ \(RefCountedChan c) -> do
+                unsubscribeToChan c
         L.putStrLn "CLIENT SESSION: close"
 
     subscribe session Nothing = do
         let tmvar = localSubscriber (presence_state session)
-        atomically $ subscribeToChan tmvar
+        atomically $ do
+            cs <- readTVar (chans session)
+            writeTVar (chans session) (RefCountedChan tmvar:cs)
+            subscribeToChan tmvar
     subscribe session (Just jid) = do -- UNUSED as yet
         let tvar = subscriberMap (presence_state session)
         atomically $ subscribeToMap tvar jid
 
+    subscribeToRoster session = do
+        let rchan = rosterChannel . presence_state $ session
+        atomically $ do
+            cs <- readTVar (chans session)
+            writeTVar (chans session) (RefCountedChan rchan:cs)
+            subscribeToChan rchan
+            
+
     forCachedPresence s action = do
         jid <- getJID s 
         L.putStrLn $ "forCachedPresence "<++> bshow jid
@@ -171,6 +190,13 @@ instance JabberClientSession ClientSession where
     addSolicited s jid = do
         user <- readIORef (unix_uid s) >>= getJabberUserForId
         ConfigFiles.addSolicited user jid -- (L.show jid)
+        let rchan = rosterChannel . presence_state $ s
+        atomically $ do
+            isempty <- isEmptyTMVar rchan
+            when (not isempty) $ do
+            (_,ch) <- readTMVar rchan
+            writeTChan ch (RequestedSubscription user jid)
+            
 
     getMyBuddies s = do
         user <- readIORef (unix_uid s) >>= getJabberUserForId
@@ -251,6 +277,9 @@ instance JabberPeerSession PeerSession where
     getSubscribers _ user = ConfigFiles.getSubscribers user
 
 
+data RefCountedChan = forall a. RefCountedChan (TMVar (RefCount,TChan a))
+
+subscribeToChan :: TMVar (RefCount, TChan a) -> STM (TChan a)
 subscribeToChan tmvar =
             (do (cnt,chan) <- takeTMVar tmvar
                 putTMVar tmvar (cnt+1,chan)
@@ -260,6 +289,12 @@ subscribeToChan tmvar =
             (do chan <- newTChan
                 putTMVar tmvar (1,chan)
                 return chan )
+unsubscribeToChan :: TMVar (RefCount,TChan a) -> STM ()
+unsubscribeToChan tmvar = do
+    isEmpty <- isEmptyTMVar tmvar
+    when (not isEmpty) $ do
+    (cnt,chan) <- takeTMVar tmvar
+    when (cnt>1) (putTMVar tmvar (cnt-1,chan))
 
 getRefFromMap tvar key newObject copyObject = do
     subs <- readTVar tvar
@@ -322,9 +357,10 @@ newPresenceState hostname = atomically $ do
     us   <- newTVar (Set.empty)
     subs <- newTVar (Map.empty)
     locals_greedy <- newEmptyTMVar
+    rchan <- newEmptyTMVar
     remotes <- newTVar (Map.empty)
     server_connections <- newServerConnections
-    return $ PresenceState hostname tty us subs locals_greedy remotes server_connections
+    return $ PresenceState hostname tty us subs locals_greedy rchan remotes server_connections
 
 sendProbes state jid = do
     L.putStrLn $ "sending probes for " <++> bshow jid