From 738205cba2147939120d8f17f9de7cbe5ef8e3c3 Mon Sep 17 00:00:00 2001 From: ndwarshuis Date: Thu, 26 Mar 2020 09:37:46 -0400 Subject: [PATCH] REF move process functions to their own module --- bin/xmonad.hs | 64 ++++++++++++++------------------------------- lib/Process.hs | 44 +++++++++++++++++++++++++++++++ lib/WorkspaceMon.hs | 16 +++--------- my-xmonad.cabal | 3 ++- 4 files changed, 69 insertions(+), 58 deletions(-) create mode 100644 lib/Process.hs diff --git a/bin/xmonad.hs b/bin/xmonad.hs index 862610e..3aa6d56 100644 --- a/bin/xmonad.hs +++ b/bin/xmonad.hs @@ -4,18 +4,17 @@ module Main (main) where import ACPI -import DBus.Client (Client) -import Notify -import SendXMsg -import Shell -import WorkspaceMon - import DBus.Common import DBus.IntelBacklight import DBus.Screensaver - +import Notify +import Process +import SendXMsg +import Shell import qualified Theme as T +import WorkspaceMon +import Control.Arrow (first) import Control.Concurrent import Control.Monad ( forM @@ -30,27 +29,19 @@ import qualified Data.Map.Lazy as M import Data.Maybe (catMaybes, isJust) import Data.Monoid (All (..)) +import DBus.Client (Client) + import Graphics.X11.Types import Graphics.X11.Xlib.Atom import Graphics.X11.Xlib.Extras import Graphics.X11.Xrandr -import Control.Arrow (first) -import Control.Exception - import System.Directory import System.Exit import System.IO import System.Posix.IO import System.Posix.Process -import System.Posix.Signals import System.Posix.Types -import System.Process (waitForProcess) -import System.Process.Internals - ( ProcessHandle__ (ClosedHandle, OpenHandle) - , mkProcessHandle - , withProcessHandle - ) import Text.Read (readMaybe) @@ -72,12 +63,11 @@ import XMonad.Layout.PerWorkspace import XMonad.Layout.Tabbed import XMonad.Prompt import XMonad.Prompt.ConfirmPrompt +import qualified XMonad.StackSet as W import XMonad.Util.EZConfig import XMonad.Util.NamedActions import XMonad.Util.Run -import qualified XMonad.StackSet as W - main :: IO () main = do dbClient <- startXMonadService @@ -196,9 +186,6 @@ myWindowSetXinerama ws = wsString ++ sep ++ layout (_, Rectangle x0 _ _ _) = getScreenIdAndRectangle s0 (_, Rectangle x1 _ _ _) = getScreenIdAndRectangle s1 -getFocusedScreen :: X Rectangle -getFocusedScreen = withWindowSet $ return . screenRect . W.screenDetail . W.current - myManageHook :: ManageHook myManageHook = composeOne -- assume virtualbox is not run with the toolbar in fullscreen mode @@ -235,7 +222,7 @@ myEventHook ClientMessageEvent { ev_message_type = t, ev_data = d } ACPI -> do let acpiTag = toEnum <$> readMaybe tag :: Maybe ACPIEvent forM_ acpiTag $ \case - Power -> myPowerPrompt + Power -> runPowerPrompt Sleep -> confirmPrompt T.promptTheme "suspend?" runSuspend LidClose -> do status <- io isDischarging @@ -281,8 +268,8 @@ instance Enum PowerAction where fromEnum Hibernate = 2 fromEnum Reboot = 3 -myPowerPrompt :: X () -myPowerPrompt = mkXPrompt PowerPrompt theme comp executeAction +runPowerPrompt :: X () +runPowerPrompt = mkXPrompt PowerPrompt theme comp executeAction where comp = mkComplFunFromList [] theme = T.promptTheme { promptKeymap = keymap } @@ -303,8 +290,8 @@ myPowerPrompt = mkXPrompt PowerPrompt theme comp executeAction Hibernate -> runScreenLock >> runHibernate Reboot -> runReboot -myQuitPrompt :: X () -myQuitPrompt = confirmPrompt T.promptTheme "quit?" $ io exitSuccess +runQuitPrompt :: X () +runQuitPrompt = confirmPrompt T.promptTheme "quit?" $ io exitSuccess -- TODO for some reason the screen never wakes up after suspend when -- the nvidia card is up, so block suspend if nvidia card is running @@ -377,6 +364,9 @@ getMonitorName = do (Rectangle x y _ _) <- getFocusedScreen return (fromIntegral x, fromIntegral y) +getFocusedScreen :: X Rectangle +getFocusedScreen = withWindowSet $ return . screenRect . W.screenDetail . W.current + spawnDmenuCmd :: String -> [String] -> X () spawnDmenuCmd cmd args = do name <- getMonitorName @@ -454,21 +444,6 @@ runCleanup ps client = io $ do mapM_ killPID ps stopXMonadService client -killPID :: ProcessID -> IO () -killPID pID = do - h <- mkProcessHandle pID False - -- this may fail of the PID does not exist - _ <- try $ sendSIGTERM h :: IO (Either IOException ()) - -- this may fail if the process exits instantly and the handle - -- is destroyed by the time we get to this line (I think?) - _ <- try $ waitForProcess h :: IO (Either IOException ExitCode) - return () - where - sendSIGTERM h = withProcessHandle h $ \case - OpenHandle _ -> signalProcess sigTERM pID - ClosedHandle _ -> return () - _ -> return () -- this should never happen - runRestart :: X () runRestart = restart "xmonad" True @@ -630,6 +605,7 @@ myKeys hs client c = , ("M-C-t", addName "launch terminal" runTerm) , ("M-C-q", addName "launch calc" runCalc) , ("M-C-f", addName "launch file manager" runFileManager) + -- TODO shoudn't these be flipped? , ("M-C-v", addName "launch windows VM" $ runVBox >> appendWorkspace myVMWorkspace) , ("M-C-g", addName "launch GIMP" $ runGimp >> appendWorkspace myGimpWorkspace) ] ++ @@ -653,7 +629,7 @@ myKeys hs client c = , ("M-M1-=", addName "toggle screensaver" toggleDPMS) , ("M-", addName "restart xmonad" $ runCleanup hs client >> runRestart) , ("M-S-", addName "recompile xmonad" runRecompile) - , ("M-", addName "power menu" myPowerPrompt) - , ("M-", addName "quit xmonad" myQuitPrompt) + , ("M-", addName "power menu" runPowerPrompt) + , ("M-", addName "quit xmonad" runQuitPrompt) , ("M-", addName "switch gpu" runOptimusPrompt) ] diff --git a/lib/Process.hs b/lib/Process.hs new file mode 100644 index 0000000..b50eb52 --- /dev/null +++ b/lib/Process.hs @@ -0,0 +1,44 @@ +{-# LANGUAGE LambdaCase #-} + +module Process where + +import Control.Concurrent +import Control.Exception +import Control.Monad + +import System.Directory +import System.Exit +import System.Posix.Signals +import System.Posix.Types +import System.Process (waitForProcess) +import System.Process.Internals + ( ProcessHandle__ (ClosedHandle, OpenHandle) + , mkProcessHandle + , withProcessHandle + ) + +-- | Block until a PID has exited (in any form) +-- ASSUMPTION on linux PIDs will always increase until they overflow, in which +-- case they will start to recycle. Barring any fork bombs, this code should +-- work because we can reasonably expect that no processes will spawn with the +-- same PID within the delay limit +-- TODO this will not work if the process is a zombie (maybe I care...) +waitUntilExit :: Show t => t -> IO () +waitUntilExit pid = do + res <- doesDirectoryExist $ "/proc/" ++ show pid + when res $ threadDelay 100000 >> waitUntilExit pid + +killPID :: ProcessID -> IO () +killPID pid = do + h <- mkProcessHandle pid False + -- this may fail of the PID does not exist + _ <- try $ sendSIGTERM h :: IO (Either IOException ()) + -- this may fail if the process exits instantly and the handle + -- is destroyed by the time we get to this line (I think?) + _ <- try $ waitForProcess h :: IO (Either IOException ExitCode) + return () + where + sendSIGTERM h = withProcessHandle h $ \case + OpenHandle _ -> signalProcess sigTERM pid + ClosedHandle _ -> return () + _ -> return () -- this should never happen diff --git a/lib/WorkspaceMon.hs b/lib/WorkspaceMon.hs index 1661354..55e87f2 100644 --- a/lib/WorkspaceMon.hs +++ b/lib/WorkspaceMon.hs @@ -2,6 +2,7 @@ module WorkspaceMon (M.fromList, runWorkspaceMon) where +import Process import SendXMsg import qualified Data.Map as M @@ -19,7 +20,6 @@ import Graphics.X11.Xlib.Extras import Graphics.X11.Xlib.Misc import Graphics.X11.Xlib.Types -import System.Directory import System.Process (Pid) -- TOOD it would be really nice if the manner we used to match windows was @@ -81,18 +81,8 @@ handle curPIDs MapNotifyEvent { ev_window = w } = do handle _ _ = return () waitAndKill :: String -> Pid -> IO () -waitAndKill tag pid = waitUntilExit pidDir - where - pidDir = "/proc/" ++ show pid - waitUntilExit d = do - -- TODO this will not work if the process is a zombie (maybe I care...) - -- ASSUMPTION on linux PIDs will always increase until they overflow, in - -- which case they will start to recycle. Barring any fork bombs, this - -- code should work because we can reasonably expect that no processes - -- will spawn with the same PID within the delay limit - res <- doesDirectoryExist d - if res then threadDelay 100000 >> waitUntilExit d - else sendXMsg Workspace tag +waitAndKill tag pid = waitUntilExit pid >> sendXMsg Workspace tag + withUniquePid :: WatchedPIDs -> Pid -> IO () -> IO () withUniquePid curPIDs pid f = do diff --git a/my-xmonad.cabal b/my-xmonad.cabal index e0e8465..e48b253 100644 --- a/my-xmonad.cabal +++ b/my-xmonad.cabal @@ -15,6 +15,7 @@ library , DBus.IntelBacklight , DBus.Internal , DBus.Screensaver + , Process , Xmobar.Common , Xmobar.Plugins.Bluetooth , Xmobar.Plugins.IntelBacklight @@ -29,6 +30,7 @@ library , fdo-notify , io-streams >= 1.5.1.0 , mtl >= 2.2.2 + , unix >= 2.7.2.2 , tcp-streams >= 1.0.1.1 , text >= 1.2.3.1 , directory >= 1.3.3.0 @@ -47,7 +49,6 @@ executable xmonad , dbus >= 1.2.7 , directory >= 1.3.3.0 , my-xmonad - , process >= 1.6.5.0 , unix >= 2.7.2.2 , xmonad >= 0.13 , xmonad-contrib >= 0.13