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

This fixes several issues related to parsing of parent PIDs: * A process with lines or spaces or parentheses in its process name would confuse the code in X.A.SpawnOn and possibly lead to a `Prelude.read: no parse` exception. * `X.H.WindowSwallowing.isChildOf` looked for the parent PID anywhere in the output of pstree, so single-digit parent PIDs would be considered as parents of any process with that digit anywhere in its chain of parent PIDs. (Note that apps in PID namespaces like in Flatpak often have single-digit PIDs.) * `pstree` is no longer required in `$PATH`. Fixes: xmonad#726
PRESFIL · Jul 6, 2022 · fc482b8 · fc482b8
1 parent 5557944
commit fc482b8
Show file tree

Hide file tree

Showing 6 changed files with 92 additions and 53 deletions.
diff --git a/CHANGES.md b/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`.

diff --git a/XMonad/Actions/SpawnOn.hs b/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
-    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
+manageSpawnWithGC garbageCollect = pid >>= \case
+    Nothing -> mempty
+    Just p -> do
+        Spawner pids <- liftX XS.get
+        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

diff --git a/XMonad/Hooks/WindowSwallowing.hs b/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

diff --git a/XMonad/Util/ExtensibleState.hs b/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

diff --git a/XMonad/Util/Process.hs b/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 <[email protected]>
+-- License     :  BSD3
+-- Maintainer  :  Tomáš Janoušek <[email protected]>
+--
+-- 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)
diff --git a/xmonad-contrib.cabal b/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