Exported ClientCommands channel to main module so that we can start

tracking clients for messaging and client status.

4 files changed, 40 insertions, 23 deletions

diff --git a/Presence/LocalPeerCred.hs b/Presence/LocalPeerCred.hs
index 14f5234a..f66421f8 100644
--- a/Presence/LocalPeerCred.hs
+++ b/Presence/LocalPeerCred.hs
@@ -104,6 +104,9 @@ parseProcNet port host h = do
 unmap6mapped4 addr@(SockAddrInet6 port _ (0,0,0xFFFF,a) _) = SockAddrInet port (toBE32 a)
 unmap6mapped4 addr = addr
 
+identifyTTY ::
+  [(W8.ByteString, ProcessID)]
+  -> UserID -> W8.ByteString -> IO (Maybe W8.ByteString, Maybe CPid)
 identifyTTY tty_pids uid inode = do
     pid <- scanProc (show uid) (L.unpack inode)
     -- putStrLn $ "scanProc --> "++show pid
@@ -122,6 +125,7 @@ identifyTTY tty_pids uid inode = do
         parseTty :: String -> Float
         parseTty = read .  tail . dropWhile (/=':') 
 
+ttyToXorgs :: Show a => [(t, a)] -> IO [([Char], t)]
 ttyToXorgs tty_pids = do
     dts' <- flip mapM tty_pids $ \(tty,pid) -> do
         cmd' <- readFile $ "/proc/"++show pid++"/cmdline"
diff --git a/Presence/XMPP.hs b/Presence/XMPP.hs
index 4c103880..378c6785 100644
--- a/Presence/XMPP.hs
+++ b/Presence/XMPP.hs
@@ -59,13 +59,6 @@ import           Data.Map as Map (Map)
 textToByteString x = L.fromChunks [S.encodeUtf8 x]
 
 
-data Commands = 
-    Send [XML.Event] 
-    | BoundToResource
-    | InterestedInRoster
-    | QuitThread 
- deriving Prelude.Show
-
 
 xmlifyPresenceForClient :: Presence -> IO [XML.Event]
 xmlifyPresenceForClient (Presence jid stat) = do
@@ -364,7 +357,7 @@ handleIQGet session cmdChan tag = do
     
 
 fromClient :: (MonadThrow m,MonadIO m, JabberClientSession session) => 
-    session -> TChan Commands -> Sink XML.Event m ()
+    session -> TChan ClientCommands -> Sink XML.Event m ()
 fromClient session cmdChan = doNestingXML $ do
     let log  = liftIO . L.putStrLn . ("(C) " <++>)
         send = liftIO . atomically . writeTChan cmdChan . Send
@@ -429,12 +422,12 @@ rosterPush to contact attrs = do
       , EventEndElement "{jabber:client}iq"
       ]
 
-data EventsForClient = CmdChan Commands 
+data EventsForClient = CmdChan ClientCommands 
                      | PChan   Presence
                      | RChan   RosterEvent
 
 toClient :: (MonadIO m, JabberClientSession session ) => 
-    session -> TChan Presence -> TChan Commands -> TChan RosterEvent -> Source m [XML.Event]
+    session -> TChan Presence -> TChan ClientCommands -> TChan RosterEvent -> Source m [XML.Event]
 toClient session pchan cmdChan rchan = toClient' False False 
  where
   toClient' isBound isInterested = do
@@ -573,7 +566,7 @@ handleClient st src snk = do
     Prelude.putStrLn $ "PEER NAME: "++Prelude.show pname
     pchan <- subscribe session Nothing
     rchan <- subscribeToRoster session
-    cmdChan <- atomically newTChan
+    let cmdChan = clientChannel session
 
     writer <- async ( toClient session pchan cmdChan rchan `xmlToByteStrings` snk ) 
     finally         ( src $= parseBytes def $$ fromClient session cmdChan )
diff --git a/Presence/XMPPTypes.hs b/Presence/XMPPTypes.hs
index a44f7fb1..84da2fed 100644
--- a/Presence/XMPPTypes.hs
+++ b/Presence/XMPPTypes.hs
@@ -41,6 +41,15 @@ import ByteStringOperators
 import SocketLike
 import GetHostByAddr
 import Data.Maybe (listToMaybe)
+import Data.XML.Types as XML (Event)
+
+data ClientCommands = 
+    Send [XML.Event] 
+    | BoundToResource
+    | InterestedInRoster
+    | QuitThread 
+ deriving Prelude.Show
+
 
 class JabberClientSession session where
     data XMPPClass session
@@ -50,6 +59,7 @@ class JabberClientSession session where
     closeSession :: session -> IO ()
     subscribe :: session -> Maybe JID -> IO (TChan Presence)
     subscribeToRoster :: session -> IO (TChan RosterEvent)
+    clientChannel :: session -> TChan ClientCommands
     forCachedPresence :: session -> (Presence -> IO ()) -> IO ()
     sendPending :: session -> IO ()
     getMyBuddies       :: session -> IO [ByteString]
diff --git a/Presence/main.hs b/Presence/main.hs
index 92ef7034..83f11df3 100644
--- a/Presence/main.hs
+++ b/Presence/main.hs
@@ -125,6 +125,8 @@ data ClientSession = ClientSession {
     --            (*not* the login name of the user)
     unix_uid :: (IORef (Maybe (UserID,L.ByteString))),
 
+    unix_pid :: Maybe CPid,
+    
     -- unix_resource:  This is the detected TTY of the connecting client.
     unix_resource :: (IORef (Maybe L.ByteString)),
 
@@ -134,6 +136,8 @@ data ClientSession = ClientSession {
     --        localSubscriber & rosterChannel of the global state record.
     chans :: TVar [RefCountedChan],
 
+    clientChannel :: TChan ClientCommands,
+
     -- presence_state: a reference to the global state.
     presence_state :: PresenceState
 }
@@ -147,20 +151,25 @@ instance JabberClientSession ClientSession where
         muid <- getLocalPeerCred' addr
         L.putStrLn $ "CLIENT SESSION: open " <++> bshow muid
         uid_ref <- newIORef muid
-        res_ref <- newIORef Nothing
+        (mtty,pid) <- getTTYandPID muid
+        res_ref <- newIORef mtty
         chans <- atomically $ newTVar []
-        return $ ClientSession (hostname state) uid_ref res_ref chans state
-
-    setResource  s  resource    = do
+        clientChan <- atomically $ newTChan 
+        return $ ClientSession (hostname state) uid_ref pid res_ref chans clientChan state
+      where
+        getTTYandPID muid = do
+            us <- fmap Set.toList . readTVarIO $ activeUsers state
+            let tailOf3 (_,a,b) = (a,b)
+            (t,pid) <- case muid of
+                          Just (uid,inode) -> identifyTTY (map tailOf3 us) uid inode
+                          Nothing          -> return (Nothing,Nothing)
+            let rsc = t `mplus` fmap ( ("pid."<++>) . bshow ) pid
+            return (rsc,pid)
+
+    setResource  s  wanted_resource    = do
         -- TODO: handle resource = empty string 
-        us <- fmap Set.toList . readTVarIO $ activeUsers (presence_state s)
-        muid <- readIORef (unix_uid s)
-        let tailOf3 (_,a,b) = (a,b)
-        (t,pid) <- case muid of
-                      Just (uid,inode) -> identifyTTY (map tailOf3 us) uid inode
-                      Nothing          -> return (Nothing,Nothing)
-        let rsc = t `mplus` fmap ( ("pid."<++>) . bshow ) pid
-            rsc' = maybe resource id rsc
+        rsc <- readIORef (unix_resource s)
+        let rsc' = maybe wanted_resource id rsc
         writeIORef (unix_resource s) (Just rsc')
         L.putStrLn $ "CLIENT SESSION: resource " <++> rsc'
 
@@ -197,6 +206,7 @@ instance JabberClientSession ClientSession where
             writeTVar (chans session) (RefCountedChan rchan:cs)
             subscribeToChan rchan
             
+    clientChannel session = Main.clientChannel session
 
     forCachedPresence s action = do
         jid <- getJID s