diff options
-rw-r--r-- | whosocket.hs | 90 |
1 files changed, 70 insertions, 20 deletions
diff --git a/whosocket.hs b/whosocket.hs index 6955830a..420b707a 100644 --- a/whosocket.hs +++ b/whosocket.hs | |||
@@ -1,15 +1,24 @@ | |||
1 | {-# LANGUAGE OverloadedStrings #-} | ||
2 | {-# LANGUAGE TupleSections #-} | ||
1 | module Main where | 3 | module Main where |
2 | 4 | ||
3 | import LocalPeerCred | 5 | import LocalPeerCred |
4 | import ControlMaybe | 6 | import ControlMaybe |
7 | import UTmp | ||
8 | import ByteStringOperators | ||
5 | 9 | ||
6 | import System.Directory | 10 | import System.Directory |
7 | import Data.Char | 11 | import Data.Char |
8 | import System.Posix.Types | 12 | import System.Posix.Types |
9 | import System.Posix.Files | 13 | import System.Posix.Files |
10 | import Data.ByteString.Lazy.Char8 as L (unpack) | 14 | import qualified Data.ByteString.Lazy.Char8 as L |
15 | ( unpack | ||
16 | , pack | ||
17 | , take | ||
18 | , putStrLn | ||
19 | ) | ||
11 | import Data.List (groupBy) | 20 | import Data.List (groupBy) |
12 | import Data.Maybe (listToMaybe) | 21 | import Data.Maybe (listToMaybe,mapMaybe,catMaybes) |
13 | 22 | ||
14 | import Network.Socket | 23 | import Network.Socket |
15 | import System.Environment | 24 | import System.Environment |
@@ -30,15 +39,13 @@ whosocket addr_str port_str = do | |||
30 | (Just port_str) | 39 | (Just port_str) |
31 | let addr = head $ map addrAddress info | 40 | let addr = head $ map addrAddress info |
32 | r <- getLocalPeerCred' addr | 41 | r <- getLocalPeerCred' addr |
33 | putStrLn $ "r{"++show addr++"} = " ++ show r | 42 | -- putStrLn $ "r{"++show addr++"} = " ++ show r |
34 | 43 | ||
35 | let Just (uid,inode) = r | 44 | tty <- maybe (return Nothing) |
36 | pid <- scanProc (show uid) (L.unpack inode) | 45 | (uncurry identifyTTY) |
37 | putStrLn $ "scanProc --> "++show pid | 46 | r |
38 | withJust pid $ \(pid,ttydev) -> do | 47 | putStrLn $ "uid = " ++ show (fmap fst r) |
39 | tty <- ttyOrDisplay pid ttydev | 48 | L.putStrLn $ "tty = " <++?> tty |
40 | putStrLn $ "pid = " ++ show pid | ||
41 | putStrLn $ "tty = " ++ show tty | ||
42 | 49 | ||
43 | return () | 50 | return () |
44 | 51 | ||
@@ -79,16 +86,8 @@ ttyOrDisplay pid ttydev = do | |||
79 | case ptty of | 86 | case ptty of |
80 | Just tty -> return tty | 87 | Just tty -> return tty |
81 | Nothing -> do | 88 | Nothing -> do |
82 | env <- handleIO_ (return "") . readFile $ "/proc/"++show pid++"/environ" | 89 | display <- readDisplayVariable pid |
83 | let vs = unzero $ groupBy (\_ c->c/='\0') env | 90 | -- putStrLn $ "display = " ++ show display |
84 | unzero [] = [] | ||
85 | unzero (v:vs) = v:map tail vs | ||
86 | keyvalue xs = (key,value) | ||
87 | where | ||
88 | (key,ys) = break (=='=') xs | ||
89 | value = case ys of { [] -> []; (_:ys') -> ys' } | ||
90 | display = listToMaybe . filter ((=="DISPLAY").fst) . map keyvalue $ vs | ||
91 | putStrLn $ "display = " ++ show display | ||
92 | case display of | 91 | case display of |
93 | Just (_,disp) -> return disp | 92 | Just (_,disp) -> return disp |
94 | _ -> return ttydev | 93 | _ -> return ttydev |
@@ -102,3 +101,54 @@ searchParentsForTTY pid ttydev = do | |||
102 | Just ppid -> do | 101 | Just ppid -> do |
103 | tty <- handleIO_ (return "") $ readSymbolicLink $ "/proc/"++ppid++"/fd/0" | 102 | tty <- handleIO_ (return "") $ readSymbolicLink $ "/proc/"++ppid++"/fd/0" |
104 | searchParentsForTTY ppid tty | 103 | searchParentsForTTY ppid tty |
104 | |||
105 | readDisplayVariable pid = do | ||
106 | env <- handleIO_ (return "") | ||
107 | . readFile $ "/proc/"++show pid++"/environ" | ||
108 | let vs = unzero $ groupBy (\_ c->c/='\0') env | ||
109 | unzero [] = [] | ||
110 | unzero (v:vs) = v:map tail vs | ||
111 | keyvalue xs = (key,value) | ||
112 | where | ||
113 | (key,ys) = break (=='=') xs | ||
114 | value = case ys of { [] -> []; (_:ys') -> ys' } | ||
115 | display = listToMaybe | ||
116 | . filter ((=="DISPLAY").fst) | ||
117 | . map keyvalue | ||
118 | $ vs | ||
119 | return display | ||
120 | |||
121 | ttyToXorgs tty_pids = do | ||
122 | dts' <- flip mapM tty_pids $ \(tty,pid) -> do | ||
123 | cmd' <- readFile $ "/proc/"++show pid++"/cmdline" | ||
124 | case listToMaybe . words . takeWhile (/='\0') $ cmd' of | ||
125 | Nothing -> return Nothing | ||
126 | Just cmd -> do | ||
127 | if notElem cmd ["gdm-session-worker"] | ||
128 | then return Nothing | ||
129 | else do | ||
130 | display <- readDisplayVariable pid | ||
131 | return (fmap ( (,tty) . snd ) display) | ||
132 | let dts = catMaybes dts' | ||
133 | return dts | ||
134 | |||
135 | identifyTTY uid inode = do | ||
136 | pid <- scanProc (show uid) (L.unpack inode) | ||
137 | -- putStrLn $ "scanProc --> "++show pid | ||
138 | flip (maybe (return Nothing)) pid $ \(pid,ttydev) -> do | ||
139 | tty <- ttyOrDisplay pid ttydev | ||
140 | |||
141 | us <- users | ||
142 | let filterTTYs (_,tty,pid) = | ||
143 | if L.take 3 tty == "tty" | ||
144 | then Just (tty,pid) | ||
145 | else Nothing | ||
146 | tty_pids = mapMaybe filterTTYs us | ||
147 | -- putStrLn $ "users = " ++ show tty_pids | ||
148 | dts <- ttyToXorgs tty_pids | ||
149 | |||
150 | -- putStrLn $ "displays = " ++ show dts | ||
151 | -- -- displays = [(":5",Chunk "tty7" Empty)] | ||
152 | |||
153 | let tty' = if take 3 tty=="tty" then Just (L.pack tty) else lookup tty dts | ||
154 | return tty' | ||