moved identifyTTY to LocalPeerCred

1 files changed, 114 insertions, 24 deletions

diff --git a/Presence/LocalPeerCred.hs b/Presence/LocalPeerCred.hs
index 0122b5d0..2d5c0628 100644
--- a/Presence/LocalPeerCred.hs
+++ b/Presence/LocalPeerCred.hs
@@ -1,23 +1,25 @@
-{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE ViewPatterns  #-}
+{-# LANGUAGE TupleSections #-}
 module LocalPeerCred where
 
-{- for main
-import System.Environment
-import Control.Monad
--}
-
 import System.Endian
-import Data.ByteString.Lazy.Char8 as L hiding (map,putStrLn,tail,splitAt,tails,filter)
-import qualified Data.ByteString.Lazy.Char8 as L (splitAt)
+import qualified Data.ByteString.Lazy.Char8 as L
+ -- hiding (map,putStrLn,tail,splitAt,tails,filter)
+ --  import qualified Data.ByteString.Lazy.Char8 as L (splitAt)
 import qualified Data.ByteString.Lazy as W8
-import Data.List (tails)
+import Data.List as List (tails,groupBy)
 import System.IO ( withFile, IOMode(..))
+import System.Directory
+import Control.Arrow (first)
+import Data.Char
 import Data.Maybe
 import Data.Binary
 import Data.Bits
 import System.Posix.Types
+import System.Posix.Files
 import Debug.Trace
 import SocketLike
+import ControlMaybe
 
 xs     ?? n | n < 0 =  Nothing
 []     ?? _         =  Nothing
@@ -71,7 +73,7 @@ as16 :: Word16 -> Word16
 as16 = id
 
 parseProcNet port host h = do
-        tcp <- hGetContents h -- Failed: tcp <- hFileSize h >>= hGet h . fromIntegral
+        tcp <- L.hGetContents h -- Failed: tcp <- hFileSize h >>= hGet h . fromIntegral
         let u = do
                     ls <- listToMaybe . tail . tails . L.lines $ tcp
                     let ws = map L.words ls
@@ -86,7 +88,7 @@ parseProcNet port host h = do
                           uid <- listToMaybe ys'
                           inode <- listToMaybe ys''
                           let peer = (port,decode addr)
-                              user = toEnum (read (unpack uid) ::Int) ::UserID  -- CUid . fromIntegral $ (read (unpack uid)::Int)
+                              user = toEnum (read (L.unpack uid) ::Int) ::UserID  -- CUid . fromIntegral $ (read (unpack uid)::Int)
                           return $ {-trace ("peer:"++show(peer,user,inode))-} (peer,(user,inode))
                           )
                     fmap snd . listToMaybe $ filter ((==(port,host)).fst) rs 
@@ -97,20 +99,108 @@ parseProcNet port host h = do
     a === b = let r= a==b in  trace ("Comparing "++show (a,b)++"-->"++show r) r
     -}
 
-{-
-main = do
-    args <- getArgs
-    let addr_str = fromJust (args??0)
-        port_str = fromJust (args??1)
-    info <- getAddrInfo (Just $ defaultHints { addrFlags = [ AI_NUMERICHOST ] }) 
-                        (Just addr_str) 
-                        (Just port_str)
-    let addrs = map addrAddress info
-    forM_ addrs $ \addr -> do
-        r <- getLocalPeerCred' addr
-        putStrLn $ "r{"++show addr++"} = " ++ show r
--}
 
 -- PEER NAME: [::ffff:127.0.0.1]:34307
 unmap6mapped4 addr@(SockAddrInet6 port _ (0,0,0xFFFF,a) _) = SockAddrInet port (toBE32 a)
 unmap6mapped4 addr = addr
+
+identifyTTY tty_pids uid inode = do
+    pid <- scanProc (show uid) (L.unpack inode)
+    -- putStrLn $ "scanProc --> "++show pid
+    flip (maybe (return Nothing)) pid $ \(pid,ttydev) -> do
+    tty <- ttyOrDisplay pid ttydev
+    -- putStrLn $ "users = " ++ show tty_pids
+    dts <- ttyToXorgs tty_pids
+    -- putStrLn $ "displays = " ++ show dts 
+    -- putStrLn $ "tty = " ++ show tty
+    -- -- displays = [(":5",Chunk "tty7" Empty)]
+    let tty' = if take 3 tty=="tty" then Just (L.pack tty) else lookup (parseTty tty) (map (first parseTty) dts)
+    return tty'
+    where
+        parseTty :: String -> Float
+        parseTty = read .  tail . dropWhile (/=':') 
+
+ttyToXorgs tty_pids = do
+    dts' <- flip mapM tty_pids $ \(tty,pid) -> do
+        cmd' <- readFile $ "/proc/"++show pid++"/cmdline"
+        case listToMaybe . words . takeWhile (/='\0') $ cmd' of
+          Nothing  -> return Nothing
+          Just cmd -> do
+            if notElem cmd ["gdm-session-worker"]
+                then return Nothing
+                else do
+                  display <- readDisplayVariable pid
+                  return (fmap ( (,tty) . snd ) display)
+    let dts = catMaybes dts'
+    return dts
+
+
+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 = do
+    ptty <- searchParentsForTTY (show pid) ttydev
+    case ptty of
+        Just tty -> return tty
+        Nothing  -> do
+            display <- readDisplayVariable pid
+            -- putStrLn $ "display = " ++ show display
+            case display of
+                Just (_,disp) -> return disp
+                _             -> return ttydev
+
+
+readDisplayVariable pid = do
+            env <- handleIO_ (return "") 
+                    . readFile $ "/proc/"++show pid++"/environ"
+            let vs = unzero $ List.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
+            return display 
+
+
+makeUidStr "4294967295" = "invalid"
+makeUidStr uid          = uid
+
+
+searchParentsForTTY pid  ttydev | take 8 ttydev == "/dev/tty" = return . Just $ drop 5 ttydev
+searchParentsForTTY "1"  ttydev | otherwise                   = return Nothing
+searchParentsForTTY pid ttydev = do
+    stat <- handleIO_ (return "") . readFile $ "/proc/"++pid++"/stat"
+    case words stat ?? 3 of
+        Nothing   -> return Nothing
+        Just ppid -> do
+          tty <- handleIO_ (return "") $ readSymbolicLink $ "/proc/"++ppid++"/fd/0"
+          searchParentsForTTY ppid tty