diff --git a/bin/vbox-start.hs b/bin/vbox-start.hs index 59cc599..cb82926 100644 --- a/bin/vbox-start.hs +++ b/bin/vbox-start.hs @@ -29,7 +29,7 @@ import Text.XML.Light import System.Environment import XMonad.Internal.Concurrent.VirtualBox -import XMonad.Internal.Process (waitUntilExit) +import XMonad.Internal.IO main :: IO () main = do @@ -46,7 +46,7 @@ runAndWait [n] = do runID i = do vmLaunch i p <- vmPID i - liftIO $ waitUntilExit p + liftIO $ mapM_ waitUntilExit p err = logError "Could not get machine ID" runAndWait _ = liftIO $ putStrLn "Usage: vbox-start VBOXNAME" diff --git a/bin/xmobar.hs b/bin/xmobar.hs index e7b4358..4a56132 100644 --- a/bin/xmobar.hs +++ b/bin/xmobar.hs @@ -21,11 +21,12 @@ import Data.List import Data.Maybe import RIO hiding (hFlush) +import qualified RIO.ByteString.Lazy as BL +import RIO.Process import qualified RIO.Text as T import System.Environment import System.IO -import System.IO.Error import Xmobar.Plugins.Bluetooth import Xmobar.Plugins.ClevoKeyboard @@ -41,7 +42,6 @@ import XMonad.Internal.DBus.Brightness.ClevoKeyboard import XMonad.Internal.DBus.Brightness.IntelBacklight import XMonad.Internal.DBus.Control import XMonad.Internal.DBus.Screensaver (ssSignalDep) -import XMonad.Internal.Process hiding (CmdSpec) import qualified XMonad.Internal.Theme as XT import Xmobar hiding ( iconOffset @@ -221,7 +221,7 @@ getVPN cl = iconDBus_ "VPN status indicator" xpfVPN root $ toAnd_ vpnDep test where root useIcon tree = DBusRoot_ (const $ vpnCmd useIcon) tree cl test = DBusIO $ IOTest_ "Use nmcli to test if VPN is present" - networkManagerPkgs $ io vpnPresent + networkManagerPkgs vpnPresent getBt :: Maybe SysClient -> BarFeature getBt = xmobarDBus "bluetooth status indicator" xpfBluetooth btDep btCmd @@ -416,19 +416,22 @@ dateCmd = CmdSpec -------------------------------------------------------------------------------- -- | low-level testing functions -vpnPresent :: IO (Maybe Msg) -vpnPresent = - go <$> tryIOError (readCreateProcessWithExitCode (proc "nmcli" args) "") +vpnPresent :: FIO (Maybe Msg) +vpnPresent = do + res <- proc "nmcli" args readProcess + return $ case res of + (ExitSuccess, out, _) | "vpn" `elem` BL.split 10 out -> Nothing + | otherwise -> Just $ Msg LevelError "vpn not found" + (ExitFailure c, _, err) -> Just $ Msg LevelError + $ T.concat + ["vpn search exited with code " + , T.pack $ show c + , ": " + , T.decodeUtf8With T.lenientDecode + $ BL.toStrict err + ] where args = ["-c", "no", "-t", "-f", "TYPE", "c", "show"] - 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 - , ": " - , T.pack err] - go (Left e) = Just $ Msg LevelError $ T.pack $ show e -------------------------------------------------------------------------------- -- | text font @@ -503,5 +506,5 @@ fmtSpecs = T.intercalate sep . fmap go go CmdSpec { csAlias = a } = T.concat [pSep, a, pSep] fmtRegions :: BarRegions -> T.Text -fmtRegions BarRegions { brLeft = l, brCenter = c, brRight = r } = T.concat $ +fmtRegions BarRegions { brLeft = l, brCenter = c, brRight = r } = T.concat [fmtSpecs l, T.singleton lSep, fmtSpecs c, T.singleton rSep, fmtSpecs r] diff --git a/lib/XMonad/Internal/Command/DMenu.hs b/lib/XMonad/Internal/Command/DMenu.hs index bad578e..48fc501 100644 --- a/lib/XMonad/Internal/Command/DMenu.hs +++ b/lib/XMonad/Internal/Command/DMenu.hs @@ -33,12 +33,12 @@ import System.Directory , getXdgDirectory ) import System.IO +import System.Process import XMonad.Core hiding (spawn) import XMonad.Internal.Command.Desktop import XMonad.Internal.DBus.Common import XMonad.Internal.Notify -import XMonad.Internal.Process import XMonad.Internal.Shell import XMonad.Util.NamedActions diff --git a/lib/XMonad/Internal/Command/Desktop.hs b/lib/XMonad/Internal/Command/Desktop.hs index 724606d..e69441d 100644 --- a/lib/XMonad/Internal/Command/Desktop.hs +++ b/lib/XMonad/Internal/Command/Desktop.hs @@ -61,7 +61,6 @@ import XMonad.Actions.Volume import XMonad.Core hiding (spawn) import XMonad.Internal.DBus.Common import XMonad.Internal.Notify -import XMonad.Internal.Process hiding (createPipe, proc) import XMonad.Internal.Shell import XMonad.Operations diff --git a/lib/XMonad/Internal/Command/Power.hs b/lib/XMonad/Internal/Command/Power.hs index 9ae61de..8f69190 100644 --- a/lib/XMonad/Internal/Command/Power.hs +++ b/lib/XMonad/Internal/Command/Power.hs @@ -42,7 +42,7 @@ import qualified RIO.Text as T import System.Directory import System.IO.Error -import XMonad.Core +import XMonad.Core hiding (spawn) import XMonad.Internal.Shell import qualified XMonad.Internal.Theme as XT import XMonad.Prompt diff --git a/lib/XMonad/Internal/Concurrent/DynamicWorkspaces.hs b/lib/XMonad/Internal/Concurrent/DynamicWorkspaces.hs index b6e8a20..4944611 100644 --- a/lib/XMonad/Internal/Concurrent/DynamicWorkspaces.hs +++ b/lib/XMonad/Internal/Concurrent/DynamicWorkspaces.hs @@ -57,6 +57,8 @@ import RIO hiding ) import qualified RIO.Set as S +import System.Process + import XMonad.Actions.DynamicWorkspaces import XMonad.Core ( ManageHook @@ -67,7 +69,7 @@ import XMonad.Core ) import XMonad.Hooks.ManageHelpers (MaybeManageHook) import XMonad.Internal.Concurrent.ClientMessage -import XMonad.Internal.Process +import XMonad.Internal.IO import XMonad.ManageHook import XMonad.Operations import qualified XMonad.StackSet as W diff --git a/lib/XMonad/Internal/DBus/Screensaver.hs b/lib/XMonad/Internal/DBus/Screensaver.hs index 56dd086..17e18b4 100644 --- a/lib/XMonad/Internal/DBus/Screensaver.hs +++ b/lib/XMonad/Internal/DBus/Screensaver.hs @@ -23,29 +23,31 @@ import qualified DBus.Introspection as I import Graphics.X11.XScreenSaver import Graphics.X11.Xlib.Display +import System.Process + import XMonad.Internal.DBus.Common -import XMonad.Internal.Process +import XMonad.Internal.Shell -------------------------------------------------------------------------------- -- | Low-level functions type SSState = Bool -- true is enabled -ssExecutable :: String +ssExecutable :: FilePath ssExecutable = "xset" toggle :: IO SSState toggle = do st <- query - -- TODO figure out how not to do this with shell commands - void $ createProcess' $ proc ssExecutable $ "s" : args st - -- TODO this assumes the command succeeds - return $ not st - where - args s = if s then ["off", "-dpms"] else ["on", "+dpms"] + let args = if st then ["off", "-dpms"] else ["on", "+dpms"] + -- this needs to be done with shell commands, because as far as I know there + -- are no Haskell bindings for DPMSDisable/Enable (from libxext) + rc <- runProcessX (proc ssExecutable $ "s" : args) "" + return $ if rc == ExitSuccess then not st else st query :: IO SSState query = do + -- TODO bracket the display dpy <- openDisplay "" xssi <- xScreenSaverQueryInfo dpy closeDisplay dpy diff --git a/lib/XMonad/Internal/IO.hs b/lib/XMonad/Internal/IO.hs index 7fe81c8..00e212f 100644 --- a/lib/XMonad/Internal/IO.hs +++ b/lib/XMonad/Internal/IO.hs @@ -21,13 +21,17 @@ module XMonad.Internal.IO -- , isWritable , PermResult(..) , getPermissionsSafe + , waitUntilExit ) where import Data.Char -import Data.Text (pack, unpack) -import Data.Text.IO as T (readFile, writeFile) +import Data.Text (pack, unpack) +import Data.Text.IO as T (readFile, writeFile) + +import RIO +import RIO.Directory +import RIO.FilePath -import System.Directory import System.IO.Error -------------------------------------------------------------------------------- @@ -124,3 +128,13 @@ getPermissionsSafe f = do -- isWritable :: FilePath -> IO (PermResult Bool) -- isWritable = fmap (fmap writable) . getPermissionsSafe + +-- | Block until a PID has exited. +-- Use this to control flow based on a process that was not explicitly started +-- by the Haskell runtime itself, and thus has no data structures to query. +waitUntilExit :: (Show t, Num t) => t -> IO () +waitUntilExit pid = do + res <- doesDirectoryExist $ "/proc" show pid + when res $ do + threadDelay 100000 + waitUntilExit pid diff --git a/lib/XMonad/Internal/Process.hs b/lib/XMonad/Internal/Process.hs index c49235c..1e493d6 100644 --- a/lib/XMonad/Internal/Process.hs +++ b/lib/XMonad/Internal/Process.hs @@ -1,75 +1,17 @@ -------------------------------------------------------------------------------- -- | Functions for managing processes -module XMonad.Internal.Process - ( waitUntilExit - -- , killHandle - -- , spawnPipe' - -- , spawnPipe - -- , spawnPipeArgs - , createProcess' - , readCreateProcessWithExitCode' - , proc' - , shell' - , spawn - , spawnAt - , module System.Process - ) where +module XMonad.Internal.Process where -import Control.Concurrent -import Control.Exception -import Control.Monad -import Control.Monad.IO.Class +-- import Control.Exception +-- import Control.Monad +-- import Control.Monad.IO.Class --- import Data.Maybe +-- import qualified RIO.Text as T -import qualified RIO.Text as T +-- import System.Exit +-- import System.IO +-- import System.Process -import System.Directory -import System.Exit -import System.IO --- import System.Posix.Signals -import System.Process +-- import XMonad.Core hiding (spawn) -import XMonad.Core hiding (spawn) - --- | 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 $ do - threadDelay 100000 - waitUntilExit pid - -withDefaultSignalHandlers :: IO a -> IO a -withDefaultSignalHandlers = - bracket_ uninstallSignalHandlers installSignalHandlers - -addGroupSession :: CreateProcess -> CreateProcess -addGroupSession cp = cp { create_group = True, new_session = True } - -createProcess' :: CreateProcess -> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -createProcess' = withDefaultSignalHandlers . createProcess - -readCreateProcessWithExitCode' :: CreateProcess -> String - -> IO (ExitCode, T.Text, T.Text) -readCreateProcessWithExitCode' c i = withDefaultSignalHandlers $ do - (r, e, p) <- readCreateProcessWithExitCode c i - return (r, T.pack e, T.pack p) - -shell' :: String -> CreateProcess -shell' = addGroupSession . shell - -proc' :: FilePath -> [String] -> CreateProcess -proc' cmd args = addGroupSession $ proc cmd args - -spawn :: MonadIO m => String -> m () -spawn = io . void . createProcess' . shell' - -spawnAt :: MonadIO m => FilePath -> String -> m () -spawnAt fp cmd = io $ void $ createProcess' $ (shell' cmd) { cwd = Just fp } diff --git a/lib/XMonad/Internal/Shell.hs b/lib/XMonad/Internal/Shell.hs index 9f3bc5b..2ec2acc 100644 --- a/lib/XMonad/Internal/Shell.hs +++ b/lib/XMonad/Internal/Shell.hs @@ -6,9 +6,15 @@ module XMonad.Internal.Shell ( fmtCmd , spawnCmd + , spawn , doubleQuote , singleQuote , skip + , runProcessX + , spawnAt + , proc' + , shell' + , createProcess' , (#!&&) , (#!||) , (#!|) @@ -17,13 +23,46 @@ module XMonad.Internal.Shell import Control.Monad.IO.Class -import qualified RIO.Text as T +import RIO +import qualified RIO.Text as T -import XMonad.Internal.Process +import System.Process + +import qualified XMonad.Core as X -------------------------------------------------------------------------------- -- | Opening subshell +withDefaultSignalHandlers :: IO a -> IO a +withDefaultSignalHandlers = + bracket_ X.uninstallSignalHandlers X.installSignalHandlers + +addGroupSession :: CreateProcess -> CreateProcess +addGroupSession cp = cp { create_group = True, new_session = True } + +createProcess' :: CreateProcess -> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) +createProcess' = withDefaultSignalHandlers . createProcess + +readProcessX :: CreateProcess -> String -> IO (ExitCode, T.Text, T.Text) +readProcessX c i = withDefaultSignalHandlers $ do + (r, e, p) <- readCreateProcessWithExitCode c i + return (r, T.pack e, T.pack p) + +runProcessX :: CreateProcess -> String -> IO ExitCode +runProcessX c i = (\(r, _, _) -> r) <$> readProcessX c i + +shell' :: String -> CreateProcess +shell' = addGroupSession . shell + +proc' :: FilePath -> [String] -> CreateProcess +proc' cmd args = addGroupSession $ proc cmd args + +spawn :: MonadIO m => String -> m () +spawn = liftIO . void . createProcess' . shell' + +spawnAt :: MonadIO m => FilePath -> String -> m () +spawnAt fp cmd = liftIO $ void $ createProcess' $ (shell' cmd) { cwd = Just fp } + spawnCmd :: MonadIO m => FilePath -> [T.Text] -> m () spawnCmd cmd args = spawn $ T.unpack $ fmtCmd cmd args