From b058d1245e26d0c238d5af6da384988037308918 Mon Sep 17 00:00:00 2001 From: ndwarshuis Date: Tue, 27 Dec 2022 14:13:13 -0500 Subject: [PATCH] ENH don't mess with signal handlers during setup --- bin/xmobar.hs | 10 ++---- bin/xmonad.hs | 48 ++++++++++++++++++-------- lib/Data/Internal/Dependency.hs | 2 +- lib/XMonad/Internal/Command/Desktop.hs | 3 +- lib/XMonad/Internal/Command/Power.hs | 7 ++-- 5 files changed, 43 insertions(+), 27 deletions(-) diff --git a/bin/xmobar.hs b/bin/xmobar.hs index 3cd0e36..1afbe6d 100644 --- a/bin/xmobar.hs +++ b/bin/xmobar.hs @@ -34,7 +34,6 @@ import Xmobar.Plugins.IntelBacklight import Xmobar.Plugins.Screensaver import Xmobar.Plugins.VPN -import System.Posix.Signals import XMonad.Core hiding (config) import XMonad.Internal.Command.Desktop import XMonad.Internal.Command.Power @@ -65,9 +64,6 @@ run = do db <- connectDBus c <- withCache $ evalConfig db disconnectDBus db - -- this is needed to prevent waitForProcess error when forking in plugins (eg - -- alsacmd) - _ <- installHandler sigCHLD Default Nothing -- this is needed to see any printed messages hFlush stdout xmobar c @@ -422,16 +418,16 @@ dateCmd = CmdSpec vpnPresent :: IO (Maybe Msg) vpnPresent = - go <$> tryIOError (readCreateProcessWithExitCode' (proc' "nmcli" args) "") + go <$> tryIOError (readCreateProcessWithExitCode (proc "nmcli" args) "") where args = ["-c", "no", "-t", "-f", "TYPE", "c", "show"] - go (Right (ExitSuccess, out, _)) = if "vpn" `elem` T.lines out then Nothing + go (Right (ExitSuccess, out, _)) = if "vpn" `elem` lines out then Nothing else Just $ Msg LevelError "vpn not found" go (Right (ExitFailure c, _, err)) = Just $ Msg LevelError $ T.concat ["vpn search exited with code " , T.pack $ show c , ": " - , err] + , T.pack err] go (Left e) = Just $ Msg LevelError $ T.pack $ show e -------------------------------------------------------------------------------- diff --git a/bin/xmonad.hs b/bin/xmonad.hs index 7b4dd74..55a160e 100644 --- a/bin/xmonad.hs +++ b/bin/xmonad.hs @@ -82,11 +82,24 @@ parse _ = usage run :: IO () run = do + -- These first two commands are only significant when xmonad is restarted. + -- The 'launch' function below this will turn off buffering (so flushes are + -- required to see stdout) and will also install xmonad's silly signal + -- handlers (which set the handlers for sigCHLD and sigPIPE to SIG_IGN). + -- Ignoring sigCHLD is particularly bad since most of my setup entails + -- spawning processes and waiting for their exit code, which totally breaks + -- when sigCHLD is ignored (since children are killed immediately without + -- the parent invoking 'wait'). Since the 'launch' function is called last + -- here, everything before should be fine except for the case where xmonad + -- is restarted, which uses 'exec' and thus should cause the buffering and + -- signal handlers to carry over to the top. + uninstallSignalHandlers + hSetBuffering stdout LineBuffering db <- connectDBusX conf <- withCache $ evalConf db ds <- getCreateDirectories -- IDK why this is necessary; nothing prior to this will print if missing - hFlush stdout + -- hFlush stdout launch conf ds getCreateDirectories :: IO Directories @@ -138,38 +151,37 @@ evalConf db@DBusState { dbSysClient = cl } = do -- start DBus interfaces first since many features after this test these -- interfaces as dependencies io $ putStrLn "hi" - io $ hFlush stdout + -- io $ hFlush stdout let fs = features cl tt <- evalAlways $ fsTabbedTheme fs io $ putStrLn "tabbed theme started" - io $ hFlush stdout - -- uninstallSignalHandlers + -- io $ hFlush stdout -- io $ print =<< readCreateProcessWithExitCode (proc "echo" ["hi"]) "" startDBusInterfaces fs io $ putStrLn "dbus started" - io $ hFlush stdout + -- io $ hFlush stdout (xmobarHandle, ts) <- startChildDaemons fs io $ putStrLn "child daemons started" - io $ hFlush stdout + -- io $ hFlush stdout startRemovableMon fs io $ putStrLn "removemon started" - io $ hFlush stdout + -- io $ hFlush stdout startPowerMon fs io $ putStrLn "powermon started" - io $ hFlush stdout + -- io $ hFlush stdout dws <- startDynWorkspaces fs io $ putStrLn "dyn workspace started" - io $ hFlush stdout + -- io $ hFlush stdout -- fb <- evalAlways $ fsFontBuilder features kbs <- filterExternal <$> evalExternal (fsKeys fs ts db) io $ putStrLn "keys started" - io $ hFlush stdout + -- io $ hFlush stdout sk <- evalAlways $ fsShowKeys fs io $ putStrLn "showkeys started" - io $ hFlush stdout + -- io $ hFlush stdout ha <- evalAlways $ fsACPIHandler fs io $ putStrLn "acpi handler started" - io $ hFlush stdout + -- io $ hFlush stdout return $ ewmh $ addKeymap dws sk kbs $ docks @@ -180,7 +192,7 @@ evalConf db@DBusState { dbSysClient = cl } = do , handleEventHook = myEventHook ha , startupHook = myStartupHook , workspaces = myWorkspaces - , logHook = myLoghook xmobarHandle + , logHook = maybe logViewports myLoghook xmobarHandle , clickJustFocuses = False , focusFollowsMouse = False , normalBorderColor = T.unpack XT.bordersColor @@ -191,9 +203,15 @@ evalConf db@DBusState { dbSysClient = cl } = do startDBusInterfaces fs = mapM_ (\f -> executeSometimes $ f $ dbSesClient db) $ fsDBusExporters fs startChildDaemons fs = do - (h, p) <- io $ spawnPipe "xmobar" + -- (h, p) <- io $ spawnPipe "xmobar" + (h, _, _, p) <- io $ createProcess $ (shell "xmobar") { std_in = CreatePipe } + io $ case h of + Just h' -> hSetBuffering h' LineBuffering + Nothing -> return () + --installSignalHandlers ps <- catMaybes <$> mapM executeSometimes (fsDaemons fs) - return (h, ThreadState (p:ps) [h]) + -- uninstallSignalHandlers + return (h, ThreadState (p:ps) $ maybeToList h) startRemovableMon fs = void $ executeSometimes $ fsRemovableMon fs $ dbSysClient db startPowerMon fs = void $ async $ void $ executeSometimes $ fsPowerMon fs diff --git a/lib/Data/Internal/Dependency.hs b/lib/Data/Internal/Dependency.hs index 2e3f0a8..9b7b563 100644 --- a/lib/Data/Internal/Dependency.hs +++ b/lib/Data/Internal/Dependency.hs @@ -681,7 +681,7 @@ testSysDependency (AccessiblePath p r w) = permMsg <$> getPermissionsSafe p shellTest :: T.Text -> T.Text -> IO (Maybe Msg) shellTest cmd msg = do - (rc, _, _) <- readCreateProcessWithExitCode' (shell $ T.unpack cmd) "" + (rc, _, _) <- readCreateProcessWithExitCode (shell $ T.unpack cmd) "" return $ case rc of ExitSuccess -> Nothing _ -> Just $ Msg LevelError msg diff --git a/lib/XMonad/Internal/Command/Desktop.hs b/lib/XMonad/Internal/Command/Desktop.hs index babeb5b..ebd16bc 100644 --- a/lib/XMonad/Internal/Command/Desktop.hs +++ b/lib/XMonad/Internal/Command/Desktop.hs @@ -257,7 +257,8 @@ runNetAppDaemon cl = Sometimes "network applet" xpfVPN where tree = toAnd_ app $ Bus networkManagerPkgs networkManagerBus app = DBusIO $ sysExe [Package Official "network-manager-applet"] "nm-applet" - cmd _ = snd <$> spawnPipe "nm-applet" + -- cmd _ = snd <$> spawnPipe "nm-applet" + cmd _ = spawnProcess "nm-applet" [] runToggleBluetooth :: Maybe SysClient -> SometimesX runToggleBluetooth cl = Sometimes "bluetooth toggle" xpfBluetooth diff --git a/lib/XMonad/Internal/Command/Power.hs b/lib/XMonad/Internal/Command/Power.hs index b179cc9..3cb9128 100644 --- a/lib/XMonad/Internal/Command/Power.hs +++ b/lib/XMonad/Internal/Command/Power.hs @@ -42,10 +42,10 @@ import qualified RIO.Text as T import System.Directory import System.Exit import System.IO.Error -import System.Process (ProcessHandle) +import System.Process (ProcessHandle, spawnProcess) import XMonad.Core -import XMonad.Internal.Process (spawnPipeArgs) +-- import XMonad.Internal.Process (spawnPipeArgs) import XMonad.Internal.Shell import qualified XMonad.Internal.Theme as XT import XMonad.Prompt @@ -96,7 +96,8 @@ runAutolock = sometimesIO_ "automatic screen lock" "xss-lock" tree cmd where tree = And_ (Only_ $ sysExe [Package Official "xss-lock"] "xss-lock") $ Only_ $ IOSometimes_ runScreenLock - cmd = snd <$> spawnPipeArgs "xss-lock" ["--ignore-sleep", "screenlock"] + -- cmd = snd <$> spawnPipeArgs "xss-lock" ["--ignore-sleep", "screenlock"] + cmd = spawnProcess "xss-lock" ["--ignore-sleep", "screenlock"] -------------------------------------------------------------------------------- -- | Confirmation prompts