{-# 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