Merge pull request #732 from liskin/getppidof

X.A.SpawnOn, X.H.WindowSwallowing: Fix parsing of process PPIDs

CHANGES.md

@@ -110,6 +110,14 @@
     - Fixed windows getting lost when used in conjunction with
       `smartBorders` and a single window.
 
+    - No longer needs `pstree` to detect child/parent relationships.
+
+    - Fixed some false positives in child/parent relationship detection.
+
+  * `XMonad.Actions.SpawnOn`
+
+    - Fixed parsing of `/proc/*/stat` to correctly handle complex process names.
+
   * `XMonad.Util.EZConfig`
 
     - Added support for Modifier Keys `KeySym`s for Emacs-like `additionalKeysP`.

XMonad/Actions/SpawnOn.hs

@@ -1,3 +1,5 @@
+{-# LANGUAGE LambdaCase #-}
+
 -----------------------------------------------------------------------------
 -- |
 -- Module       : XMonad.Actions.SpawnOn
@@ -28,11 +30,7 @@ module XMonad.Actions.SpawnOn (
     shellPromptOn
 ) where
 
-import Control.Exception (tryJust)
-import System.IO.Error (isDoesNotExistError)
-import System.IO.Unsafe (unsafePerformIO)
 import System.Posix.Types (ProcessID)
-import Text.Printf (printf)
 
 import XMonad
 import XMonad.Prelude
@@ -42,6 +40,7 @@ import XMonad.Hooks.ManageHelpers
 import XMonad.Prompt
 import XMonad.Prompt.Shell
 import qualified XMonad.Util.ExtensibleState as XS
+import XMonad.Util.Process (getPPIDChain)
 
 -- $usage
 -- You can use this module with the following in your @~\/.xmonad\/xmonad.hs@:
@@ -72,29 +71,13 @@ instance ExtensionClass Spawner where
     initialValue = Spawner []
 
 
-getPPIDOf :: ProcessID -> Maybe ProcessID
-getPPIDOf thisPid =
-    case unsafePerformIO . tryJust (guard . isDoesNotExistError) . readFile . printf "/proc/%d/stat" $ toInteger thisPid of
-      Left _         -> Nothing
-      Right contents -> case lines contents of
-                          []        -> Nothing
-                          first : _ -> case words first of
-                                         _ : _ : _ : ppid : _ -> Just $ fromIntegral (read ppid :: Int)
-                                         _                    -> Nothing
-
-getPPIDChain :: ProcessID -> [ProcessID]
-getPPIDChain thisPid = ppid_chain thisPid []
-    where ppid_chain pid' acc =
-              if pid' == 0
-              then acc
-              else case getPPIDOf pid' of
-                     Nothing   -> acc
-                     Just ppid -> ppid_chain ppid (ppid : acc)
-
 -- | Get the current Spawner or create one if it doesn't exist.
 modifySpawner :: ([(ProcessID, ManageHook)] -> [(ProcessID, ManageHook)]) -> X ()
 modifySpawner f = XS.modify (Spawner . f . pidsRef)
 
+modifySpawnerM :: ([(ProcessID, ManageHook)] -> X [(ProcessID, ManageHook)]) -> X ()
+modifySpawnerM f = XS.modifyM (fmap Spawner . f . pidsRef)
+
 -- | Provides a manage hook to react on process spawned with
 -- 'spawnOn', 'spawnHere' etc.
 manageSpawn :: ManageHook
@@ -103,22 +86,16 @@ manageSpawn = manageSpawnWithGC (return . take 20)
 manageSpawnWithGC :: ([(ProcessID, ManageHook)] -> X [(ProcessID, ManageHook)])
         -- ^ function to stop accumulation of entries for windows that never set @_NET_WM_PID@
        -> ManageHook
-manageSpawnWithGC garbageCollect = do
+manageSpawnWithGC garbageCollect = pid >>= \case
+    Nothing -> mempty
+    Just p -> do
         Spawner pids <- liftX XS.get
-    mp <- pid
-    let ppid_chain = case mp of
-                       Just winpid -> winpid : getPPIDChain winpid
-                       Nothing     -> []
-        known_window_handlers = [ mpid
-                                | ppid <- ppid_chain
-                                , Just mpid <- [lookup ppid pids] ]
-    case known_window_handlers of
-        [] -> idHook
-        (mh:_)  -> do
-            whenJust mp $ \p -> liftX $ do
-                ps <- XS.gets pidsRef
-                XS.put . Spawner =<< garbageCollect (filter ((/= p) . fst) ps)
-            mh
+        ppid_chain <- io $ getPPIDChain p
+        case mapMaybe (`lookup` pids) ppid_chain of
+            [] -> mempty
+            mh : _ -> liftX (gc p) >> mh
+  where
+    gc p = modifySpawnerM $ garbageCollect . filter ((/= p) . fst)
 
 mkPrompt :: (String -> X ()) -> XPConfig -> X ()
 mkPrompt cb c = do

XMonad/Hooks/WindowSwallowing.hs

@@ -19,9 +19,6 @@
 -- window, and allows you "swallow" that parent window for the time the new
 -- window is running.
 --
--- __NOTE__: This module depends on @pstree@ to analyze the process hierarchy, so make
--- sure that is on your @$PATH@.
---
 -- __NOTE__ that this does not always work perfectly:
 --
 -- - Because window swallowing needs to check the process hierarchy, it requires
@@ -36,7 +33,9 @@
 --   by looking at the window. This requires the @_NET_WM_PID@ X-property to be set.
 --   If any application you want to use this with does not provide the @_NET_WM_PID@,
 --   there is not much you can do except for reaching out to the author of that
---   application and asking them to set that property.
+--   application and asking them to set that property. Additionally,
+--   applications running in their own PID namespace, such as those in
+--   Flatpak, can't set a correct @_NET_WM_PID@ even if they wanted to.
 -----------------------------------------------------------------------------
 module XMonad.Hooks.WindowSwallowing
   ( -- * Usage
@@ -50,8 +49,9 @@ import qualified XMonad.StackSet               as W
 import           XMonad.Layout.SubLayouts
 import qualified XMonad.Util.ExtensibleState   as XS
 import           XMonad.Util.WindowProperties
-import           XMonad.Util.Run                ( runProcessWithInput )
+import           XMonad.Util.Process            ( getPPIDChain )
 import qualified Data.Map.Strict               as M
+import           System.Posix.Types             ( ProcessID )
 
 -- $usage
 -- You can use this module by including  the following in your @~\/.xmonad/xmonad.hs@:
@@ -226,12 +226,10 @@ moveFloatingState from to ws = ws
 -- | check if a given process is a child of another process. This depends on "pstree" being in the PATH
 -- NOTE: this does not work if the child process does any kind of process-sharing.
 isChildOf
-  :: Int -- ^ child PID
-  -> Int -- ^ parent PID
+  :: ProcessID -- ^ child PID
+  -> ProcessID -- ^ parent PID
   -> IO Bool
-isChildOf child parent = do
-  output <- runProcessWithInput "pstree" ["-T", "-p", show parent] ""
-  return $ any (show child `isInfixOf`) $ lines output
+isChildOf child parent = (parent `elem`) <$> getPPIDChain child
 
 data SwallowingState =
   SwallowingState

XMonad/Util/ExtensibleState.hs

@@ -21,6 +21,8 @@ module XMonad.Util.ExtensibleState (
                               put
                               , modify
                               , modify'
+                              , modifyM
+                              , modifyM'
                               , remove
                               , get
                               , gets
@@ -89,12 +91,20 @@ modifyStateExts f = State.modify $ \st -> st { extensibleState = f (extensibleSt
 -- | Apply a function to a stored value of the matching type or the initial value if there
 -- is none.
 modify :: (ExtensionClass a, XLike m) => (a -> a) -> m ()
-modify f = put . f =<< get
+modify = modifyM . (pure .)
 
--- | Like @modify@ but the result value is applied strictly in respect to
--- the monadic environment.
+-- | Apply an action to a stored value of the matching type or the initial value if there
+-- is none.
+modifyM :: (ExtensionClass a, XLike m) => (a -> m a) -> m ()
+modifyM f = put =<< f =<< get
+
+-- | Like 'modify' but the result value is forced to WHNF before being stored.
 modify' :: (ExtensionClass a, XLike m) => (a -> a) -> m ()
-modify' f = (put $!) . f =<< get
+modify' = modifyM' . (pure .)
+
+-- | Like 'modifyM' but the result value is forced to WHNF before being stored.
+modifyM' :: (ExtensionClass a, XLike m) => (a -> m a) -> m ()
+modifyM' f = (put $!) =<< f =<< get
 
 -- | Add a value to the extensible state field. A previously stored value with the same
 -- type will be overwritten. (More precisely: A value whose string representation of its type

XMonad/Util/Process.hs

@@ -0,0 +1,43 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE ViewPatterns #-}
+
+-- |
+-- Module      :  XMonad.Util.Process
+-- Description :  Utilities for unix processes.
+-- Copyright   :  (c) 2022 Tomáš Janoušek <tomi@nomi.cz>
+-- License     :  BSD3
+-- Maintainer  :  Tomáš Janoušek <tomi@nomi.cz>
+--
+-- This module should not be directly used by users, it's just common code for
+-- other modules.
+--
+module XMonad.Util.Process (
+    getPPIDOf,
+    getPPIDChain,
+    ) where
+
+import Control.Exception (SomeException, handle)
+import System.Posix.Types (ProcessID)
+import qualified Data.ByteString.Char8 as B
+
+import XMonad.Prelude (fi)
+
+-- | Get the parent process id (PPID) of a given process.
+getPPIDOf :: ProcessID -> IO (Maybe ProcessID)
+getPPIDOf pid =
+    handle
+        (\(_ :: SomeException) -> pure Nothing)
+        (parse <$> B.readFile ("/proc/" <> show pid <> "/stat"))
+  where
+    -- Parse PPID out of /proc/*/stat, being careful not to trip over
+    -- processes with names like ":-) 1 2 3 4 5 6".
+    -- Inspired by https://gitlab.com/procps-ng/procps/-/blob/bcce3e440a1e1ee130c7371251a39c031519336a/proc/readproc.c#L561
+    parse stat = case B.words $ snd $ B.spanEnd (/= ')') stat of
+        _ : (B.readInt -> Just (ppid, ""))  : _ -> Just (fi ppid)
+        _ -> Nothing
+
+-- | Get the chain of parent processes of a given pid. Starts with the given
+-- pid and continues up until the parent of all.
+getPPIDChain :: ProcessID -> IO [ProcessID]
+getPPIDChain pid = (pid :) <$> (maybe (pure []) getPPIDChain =<< getPPIDOf pid)

xmonad-contrib.cabal

@@ -368,6 +368,7 @@ library
                         XMonad.Util.Parser
                         XMonad.Util.Paste
                         XMonad.Util.PositionStore
+                        XMonad.Util.Process
                         XMonad.Util.PureX
                         XMonad.Util.Rectangle
                         XMonad.Util.RemoteWindows
@@ -439,6 +440,7 @@ test-suite tests
                   XMonad.Util.NamedActions
                   XMonad.Util.NamedWindows
                   XMonad.Util.Parser
+                  XMonad.Util.Process
                   XMonad.Util.PureX
                   XMonad.Util.Rectangle
                   XMonad.Util.Run
@@ -454,6 +456,7 @@ test-suite tests
   build-depends: base
                , QuickCheck >= 2
                , X11 >= 1.10 && < 1.11
+               , bytestring >= 0.10 && < 0.12
                , containers
                , directory
                , time >= 1.8 && < 1.13