1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
|
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE TupleSections #-}
module LocalPeerCred where
import System.Endian
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 as List (tails,groupBy)
import System.IO ( withFile, IOMode(..))
import System.Directory
import Control.Arrow (first)
import Data.Char
import Data.Maybe
import Data.Bits
import Data.Serialize
import Data.Word
import System.Posix.Types
import System.Posix.Files
import Logging
import Network.SocketLike
import ControlMaybe
import Data.String
import System.IO
(??) :: (Num t, Ord t) => [a] -> t -> Maybe a
xs ?? n | n < 0 = Nothing
[] ?? _ = Nothing
(x:_) ?? 0 = Just x
(_:xs) ?? n = xs ?? (n-1)
parseHex :: W8.ByteString -> W8.ByteString
parseHex bs = L.concat . parseHex' $ bs
where
parseHex' bs =
let (dnib,ts) = L.splitAt 2 bs
parseNibble x = W8.pack $ group2 toW8 (W8.unpack $ W8.map hexDigit x)
hexDigit d = d - (if d>0x39 then 0x37 else 0x30)
group2 f (x:y:ys) = f x y : group2 f ys
group2 _ _ = []
toW8 a b = shift a 4 .|. b
in parseNibble dnib :
if L.null ts
then []
else parseHex' ts
getLocalPeerCred' :: SockAddr -> IO (Maybe (UserID, W8.ByteString))
getLocalPeerCred' (unmap6mapped4 -> SockAddrInet portn host) = do
let port = fromEnum portn
{- trace ("tcp4 "++show(port,host)) $ -}
withFile "/proc/net/tcp" ReadMode (parseProcNet port host)
getLocalPeerCred' (unmap6mapped4 -> SockAddrInet6 portn flow host scope) = do
let port = fromEnum portn
(a,b,c,d) = host
host' = (toBE32 a, toBE32 b, toBE32 c, toBE32 d)
withFile "/proc/net/tcp6" ReadMode (parseProcNet port host')
getLocalPeerCred' (unmap6mapped4 -> addr@(SockAddrUnix _)) =
-- TODO: parse /proc/net/unix
-- see also: Network.Socket.getPeerCred
return Nothing
{- // Removed due to no call-sites
getLocalPeerCred :: SocketLike sock => sock -> IO (Maybe UserID)
getLocalPeerCred sock = do
addr <- getPeerName sock
muid <- getLocalPeerCred' addr
case muid of
Just (uid,inode) -> return (Just uid)
Nothing -> trace "proc failed." $ fmap (validate . CUid . fromIntegral . sndOf3) (getPeerCred sock)
where sndOf3 (pid,uid,gid) = uid
where
validate uid = Just uid -- TODO
-}
from16 :: Word16 -> Int
from16 = fromEnum
as16 :: Word16 -> Word16
as16 = id
parseProcNet :: (Serialize t, Num t1, Eq t, Eq t1) =>
t1
-> t
-> Handle
-> IO (Maybe (UserID, W8.ByteString))
parseProcNet port host h = do
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
let rs = ( catMaybes . flip map ws $ \xs -> do
let ys = snd (Prelude.splitAt 1 xs)
localaddr <- listToMaybe ys
let zs = L.splitWith (==':') localaddr
addr <- fmap parseHex $ listToMaybe zs
port <- either (const Nothing) (Just . fromIntegral . as16) . decode . L.toStrict . 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''
peer <- either (const Nothing) Just $ do
a <- decode $ L.toStrict addr
return (port,a)
let 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
{- trace ("found: "++show u) -}
u `seq` return u
{-
where
a === b = let r= a==b in trace ("Comparing "++show (a,b)++"-->"++show r) r
-}
-- PEER NAME: [::ffff:127.0.0.1]:34307
unmap6mapped4 :: SockAddr -> SockAddr
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
fromMaybe (return (Nothing,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',Just pid)
where
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"
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 :: t -> [Char] -> IO (Maybe (CPid, FilePath))
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
-- requires root (or same user as for pid)...
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 :: Show a => a -> FilePath -> IO [Char]
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 :: Show a => a -> IO (Maybe ([Char], [Char]))
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 :: (Data.String.IsString t, Eq t) => t -> t
makeUidStr "4294967295" = "invalid"
makeUidStr uid = uid
searchParentsForTTY :: String -> FilePath -> IO (Maybe [Char])
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
|
