whosocket.hs demonstrates acquiring uid,pid,tty/display from

a local socket address and port number.

4 files changed, 123 insertions, 25 deletions

diff --git a/Presence/ControlMaybe.hs b/Presence/ControlMaybe.hs
index e277df12..37f6f93c 100644
--- a/Presence/ControlMaybe.hs
+++ b/Presence/ControlMaybe.hs
@@ -1,5 +1,9 @@
+{-# LANGUAGE ScopedTypeVariables #-}
 module ControlMaybe where
 
+-- import GHC.IO.Exception (IOException(..))
+import Control.Exception as Exception (IOException(..),catch)
+
 withJust (Just x) f = f x
 withJust Nothing  f = return ()
 
@@ -8,3 +12,8 @@ whenJust acn f = do
     withJust x f
 
 
+catchIO_ :: IO a -> IO a -> IO a
+catchIO_ a h = Exception.catch a (\(_ :: IOException) -> h)
+
+handleIO_ = flip catchIO_
+
diff --git a/Presence/LocalPeerCred.hs b/Presence/LocalPeerCred.hs
index d3b8d189..b6ec9491 100644
--- a/Presence/LocalPeerCred.hs
+++ b/Presence/LocalPeerCred.hs
@@ -57,7 +57,7 @@ getLocalPeerCred sock = do
     addr <- getPeerName sock
     muid <- getLocalPeerCred' addr
     case muid of
-        Just uid -> return (Just uid)
+        Just (uid,inode) -> return (Just uid)
         Nothing  -> trace "proc failed." $ fmap (validate . CUid . fromIntegral . sndOf3) (getPeerCred sock)
                      where sndOf3 (pid,uid,gid) = uid
  where
@@ -81,10 +81,12 @@ parseProcNet port host h = do
                           addr <- fmap parseHex $ listToMaybe zs
                           port <- fmap (fromIntegral . as16 . decode . parseHex) $ listToMaybe $ snd (Prelude.splitAt 1 zs)
                           let ys' = snd (Prelude.splitAt 5 (tail ys))
+                              ys'' = snd (Prelude.splitAt 2 ys')
                           uid <- listToMaybe ys'
+                          inode <- listToMaybe ys''
                           let peer = (port,decode addr)
                               user = toEnum (read (unpack uid) ::Int) ::UserID  -- CUid . fromIntegral $ (read (unpack uid)::Int)
-                          return $ {- trace ("peer:"++show(peer,user)) -} (peer,user)
+                          return $ {-trace ("peer:"++show(peer,user,inode))-} (peer,(user,inode))
                           )
                     fmap snd . listToMaybe $ filter ((==(port,host)).fst) rs 
         {- trace ("found: "++show u) -} 
diff --git a/Presence/XMPP.hs b/Presence/XMPP.hs
index 3f81f000..d35e5617 100644
--- a/Presence/XMPP.hs
+++ b/Presence/XMPP.hs
@@ -241,21 +241,25 @@ tagName (EventBeginElement n _) = n
 tagName _                       = ""
 
 handleIQSetBind session cmdChan stanza_id = do
-    whenJust nextElement $ \child -> do
-    let unhandledBind = liftIO $ putStrLn $ "unhandled-bind: "++show child
-    case tagName child of
-        "{urn:ietf:params:xml:ns:xmpp-bind}resource"
-          -> do
-            rsc <- lift content
-            liftIO $ do
-                putStrLn $ "iq-set-bind-resource " ++ show rsc
-                setResource session (L.fromChunks [S.encodeUtf8 rsc])
-                jid <- getJID session
-                atomically $ writeTChan cmdChan (Send $ iq_bind_reply stanza_id (toStrict $ L.decodeUtf8 $ L.show jid) )
-                forCachedPresence session $ \presence -> do
-                    xs <- xmlifyPresenceForClient presence
-                    atomically . writeTChan cmdChan . Send $ xs
-        _ -> unhandledBind
+    mchild <- nextElement
+    case mchild of
+     Just child -> do
+        let unhandledBind = liftIO $ putStrLn $ "unhandled-bind: "++show child
+        case tagName child of
+            "{urn:ietf:params:xml:ns:xmpp-bind}resource"
+              -> do
+                rsc <- lift content
+                liftIO $ do
+                    putStrLn $ "iq-set-bind-resource " ++ show rsc
+                    setResource session (L.fromChunks [S.encodeUtf8 rsc])
+                    jid <- getJID session
+                    atomically $ writeTChan cmdChan (Send $ iq_bind_reply stanza_id (toStrict $ L.decodeUtf8 $ L.show jid) )
+                    forCachedPresence session $ \presence -> do
+                        xs <- xmlifyPresenceForClient presence
+                        atomically . writeTChan cmdChan . Send $ xs
+            _ -> unhandledBind
+     Nothing -> do
+        liftIO $ putStrLn $ "empty bind request!"
 
 
 iq_session_reply host stanza_id =
@@ -598,14 +602,6 @@ fromPeer session = doNestingXML $ do
 
 
 
-{-
-seekRemotePeers :: XMPPConfig config =>
-     config -> TChan Presence -> IO ()
-seekRemotePeers config chan = do
-    putStrLn "unimplemented: seekRemotePeers"
-    -- TODO
-    return ()
--}
 
 data OutBoundMessage = OutBoundPresence Presence | PresenceProbe JID JID
  deriving Prelude.Show
diff --git a/whosocket.hs b/whosocket.hs
new file mode 100644
index 00000000..5968b152
--- /dev/null
+++ b/whosocket.hs
@@ -0,0 +1,91 @@
+module Main where
+
+import LocalPeerCred
+import ControlMaybe
+
+import System.Directory
+import Data.Char
+import System.Posix.Types
+import System.Posix.Files
+import Data.ByteString.Lazy.Char8 as L (unpack)
+import Data.List (groupBy)
+import Data.Maybe (listToMaybe)
+
+import Network.Socket
+import System.Environment
+import Control.Arrow (first)
+
+usage = do
+    putStrLn $ "whosocket numeric-address port"
+
+main = do
+    args <- getArgs
+    case (args??0,args??1) of
+        (Just addr_str,Just port_str) -> whosocket addr_str port_str
+        _                             -> usage
+
+whosocket addr_str port_str = do
+    info <- getAddrInfo (Just $ defaultHints { addrFlags = [ AI_NUMERICHOST ] }) 
+                        (Just addr_str) 
+                        (Just port_str)
+    let addr = head $ map addrAddress info
+    r <- getLocalPeerCred' addr
+    putStrLn $ "r{"++show addr++"} = " ++ show r
+
+    let Just (uid,inode) = r
+    pid <- scanProc (show uid) (L.unpack inode)
+    putStrLn $ "scanProc --> "++show pid
+    withJust pid $ \(pid,ttydev) -> do
+    tty <- ttyOrDisplay pid ttydev
+    putStrLn $ "pid = " ++ show pid
+    putStrLn $ "tty = " ++ show tty
+
+    return ()
+
+
+makeUidStr "4294967295" = "invalid"
+makeUidStr uid          = uid
+
+
+scanProc uid inode = do
+    contents <- getDirectoryContents "/proc" `catchIO_` return []
+    let pids = reverse $ filter (\n -> not (null n) && isDigit (head n)) contents
+    let searchPids []         = return Nothing
+        searchPids (pid:pids) =  do
+            loginuid <- fmap makeUidStr $ readFile $ "/proc/"++pid++"/loginuid"
+            if False -- (uid/=loginuid) -- this check proved bad when mcabber ran on tty3
+             then searchPids pids
+             else do
+                -- putStrLn $ "pid "++show pid ++ " --> uid "++show loginuid
+                let loop [] = return Nothing
+                    loop ("0":fds) = loop fds
+                    loop (fd:fds) = do
+                      handleIO_ (loop fds) $ do
+                          what <- readSymbolicLink $ "/proc/"++pid++"/fd/"++fd
+                          -- putStrLn $ " what= "++show what
+                          if (what=="socket:["++inode++"]")
+                            then do
+                              tty <- readSymbolicLink $ "/proc/"++pid++"/fd/0"
+                              return (Just (pid,tty))
+                            else loop fds
+                fds <- getDirectoryContents ("/proc/"++pid++"/fd") `catchIO_` return []
+                mb <- loop fds
+                maybe (searchPids pids) (return . Just) mb
+
+    fmap (fmap (first (read :: String -> CPid))) $ searchPids pids
+
+ttyOrDisplay pid ttydev | take 8 ttydev == "/dev/tty" = return (drop 5 ttydev)
+ttyOrDisplay pid ttydev = do
+    env <- handleIO_ (return "") . readFile $ "/proc/"++show pid++"/environ"
+    let vs = unzero $ groupBy (\_ c->c/='\0') env
+        unzero []     = []
+        unzero (v:vs) = v:map tail vs
+        keyvalue xs = (key,value) 
+          where
+            (key,ys) = break (=='=') xs
+            value = case ys of { [] -> [];  (_:ys') -> ys' }
+        display = listToMaybe . filter ((=="DISPLAY").fst) . map keyvalue $ vs
+    putStrLn $ "display = " ++ show display
+    case display of
+        Just (_,disp) -> return disp
+        _             -> return ttydev