REF get rid of internal proc module

This commit is contained in:
Nathan Dwarshuis 2022-12-29 00:06:55 -05:00
parent 246208e3cf
commit 70541ca5b1
10 changed files with 102 additions and 101 deletions

View File

@ -29,7 +29,7 @@ import Text.XML.Light
import System.Environment import System.Environment
import XMonad.Internal.Concurrent.VirtualBox import XMonad.Internal.Concurrent.VirtualBox
import XMonad.Internal.Process (waitUntilExit) import XMonad.Internal.IO
main :: IO () main :: IO ()
main = do main = do
@ -46,7 +46,7 @@ runAndWait [n] = do
runID i = do runID i = do
vmLaunch i vmLaunch i
p <- vmPID i p <- vmPID i
liftIO $ waitUntilExit p liftIO $ mapM_ waitUntilExit p
err = logError "Could not get machine ID" err = logError "Could not get machine ID"
runAndWait _ = liftIO $ putStrLn "Usage: vbox-start VBOXNAME" runAndWait _ = liftIO $ putStrLn "Usage: vbox-start VBOXNAME"

View File

@ -21,11 +21,12 @@ import Data.List
import Data.Maybe import Data.Maybe
import RIO hiding (hFlush) import RIO hiding (hFlush)
import qualified RIO.ByteString.Lazy as BL
import RIO.Process
import qualified RIO.Text as T import qualified RIO.Text as T
import System.Environment import System.Environment
import System.IO import System.IO
import System.IO.Error
import Xmobar.Plugins.Bluetooth import Xmobar.Plugins.Bluetooth
import Xmobar.Plugins.ClevoKeyboard import Xmobar.Plugins.ClevoKeyboard
@ -41,7 +42,6 @@ import XMonad.Internal.DBus.Brightness.ClevoKeyboard
import XMonad.Internal.DBus.Brightness.IntelBacklight import XMonad.Internal.DBus.Brightness.IntelBacklight
import XMonad.Internal.DBus.Control import XMonad.Internal.DBus.Control
import XMonad.Internal.DBus.Screensaver (ssSignalDep) import XMonad.Internal.DBus.Screensaver (ssSignalDep)
import XMonad.Internal.Process hiding (CmdSpec)
import qualified XMonad.Internal.Theme as XT import qualified XMonad.Internal.Theme as XT
import Xmobar hiding import Xmobar hiding
( iconOffset ( iconOffset
@ -221,7 +221,7 @@ getVPN cl = iconDBus_ "VPN status indicator" xpfVPN root $ toAnd_ vpnDep test
where where
root useIcon tree = DBusRoot_ (const $ vpnCmd useIcon) tree cl root useIcon tree = DBusRoot_ (const $ vpnCmd useIcon) tree cl
test = DBusIO $ IOTest_ "Use nmcli to test if VPN is present" test = DBusIO $ IOTest_ "Use nmcli to test if VPN is present"
networkManagerPkgs $ io vpnPresent networkManagerPkgs vpnPresent
getBt :: Maybe SysClient -> BarFeature getBt :: Maybe SysClient -> BarFeature
getBt = xmobarDBus "bluetooth status indicator" xpfBluetooth btDep btCmd getBt = xmobarDBus "bluetooth status indicator" xpfBluetooth btDep btCmd
@ -416,19 +416,22 @@ dateCmd = CmdSpec
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | low-level testing functions -- | low-level testing functions
vpnPresent :: IO (Maybe Msg) vpnPresent :: FIO (Maybe Msg)
vpnPresent = vpnPresent = do
go <$> tryIOError (readCreateProcessWithExitCode (proc "nmcli" args) "") res <- proc "nmcli" args readProcess
where return $ case res of
args = ["-c", "no", "-t", "-f", "TYPE", "c", "show"] (ExitSuccess, out, _) | "vpn" `elem` BL.split 10 out -> Nothing
go (Right (ExitSuccess, out, _)) = if "vpn" `elem` lines out then Nothing | otherwise -> Just $ Msg LevelError "vpn not found"
else Just $ Msg LevelError "vpn not found" (ExitFailure c, _, err) -> Just $ Msg LevelError
go (Right (ExitFailure c, _, err)) = Just $ Msg LevelError $ T.concat
$ T.concat ["vpn search exited with code " ["vpn search exited with code "
, T.pack $ show c , T.pack $ show c
, ": " , ": "
, T.pack err] , T.decodeUtf8With T.lenientDecode
go (Left e) = Just $ Msg LevelError $ T.pack $ show e $ BL.toStrict err
]
where
args = ["-c", "no", "-t", "-f", "TYPE", "c", "show"]
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | text font -- | text font
@ -503,5 +506,5 @@ fmtSpecs = T.intercalate sep . fmap go
go CmdSpec { csAlias = a } = T.concat [pSep, a, pSep] go CmdSpec { csAlias = a } = T.concat [pSep, a, pSep]
fmtRegions :: BarRegions -> T.Text 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] [fmtSpecs l, T.singleton lSep, fmtSpecs c, T.singleton rSep, fmtSpecs r]

View File

@ -33,12 +33,12 @@ import System.Directory
, getXdgDirectory , getXdgDirectory
) )
import System.IO import System.IO
import System.Process
import XMonad.Core hiding (spawn) import XMonad.Core hiding (spawn)
import XMonad.Internal.Command.Desktop import XMonad.Internal.Command.Desktop
import XMonad.Internal.DBus.Common import XMonad.Internal.DBus.Common
import XMonad.Internal.Notify import XMonad.Internal.Notify
import XMonad.Internal.Process
import XMonad.Internal.Shell import XMonad.Internal.Shell
import XMonad.Util.NamedActions import XMonad.Util.NamedActions

View File

@ -61,7 +61,6 @@ import XMonad.Actions.Volume
import XMonad.Core hiding (spawn) import XMonad.Core hiding (spawn)
import XMonad.Internal.DBus.Common import XMonad.Internal.DBus.Common
import XMonad.Internal.Notify import XMonad.Internal.Notify
import XMonad.Internal.Process hiding (createPipe, proc)
import XMonad.Internal.Shell import XMonad.Internal.Shell
import XMonad.Operations import XMonad.Operations

View File

@ -42,7 +42,7 @@ import qualified RIO.Text as T
import System.Directory import System.Directory
import System.IO.Error import System.IO.Error
import XMonad.Core import XMonad.Core hiding (spawn)
import XMonad.Internal.Shell import XMonad.Internal.Shell
import qualified XMonad.Internal.Theme as XT import qualified XMonad.Internal.Theme as XT
import XMonad.Prompt import XMonad.Prompt

View File

@ -57,6 +57,8 @@ import RIO hiding
) )
import qualified RIO.Set as S import qualified RIO.Set as S
import System.Process
import XMonad.Actions.DynamicWorkspaces import XMonad.Actions.DynamicWorkspaces
import XMonad.Core import XMonad.Core
( ManageHook ( ManageHook
@ -67,7 +69,7 @@ import XMonad.Core
) )
import XMonad.Hooks.ManageHelpers (MaybeManageHook) import XMonad.Hooks.ManageHelpers (MaybeManageHook)
import XMonad.Internal.Concurrent.ClientMessage import XMonad.Internal.Concurrent.ClientMessage
import XMonad.Internal.Process import XMonad.Internal.IO
import XMonad.ManageHook import XMonad.ManageHook
import XMonad.Operations import XMonad.Operations
import qualified XMonad.StackSet as W import qualified XMonad.StackSet as W

View File

@ -23,29 +23,31 @@ import qualified DBus.Introspection as I
import Graphics.X11.XScreenSaver import Graphics.X11.XScreenSaver
import Graphics.X11.Xlib.Display import Graphics.X11.Xlib.Display
import System.Process
import XMonad.Internal.DBus.Common import XMonad.Internal.DBus.Common
import XMonad.Internal.Process import XMonad.Internal.Shell
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Low-level functions -- | Low-level functions
type SSState = Bool -- true is enabled type SSState = Bool -- true is enabled
ssExecutable :: String ssExecutable :: FilePath
ssExecutable = "xset" ssExecutable = "xset"
toggle :: IO SSState toggle :: IO SSState
toggle = do toggle = do
st <- query st <- query
-- TODO figure out how not to do this with shell commands let args = if st then ["off", "-dpms"] else ["on", "+dpms"]
void $ createProcess' $ proc ssExecutable $ "s" : args st -- this needs to be done with shell commands, because as far as I know there
-- TODO this assumes the command succeeds -- are no Haskell bindings for DPMSDisable/Enable (from libxext)
return $ not st rc <- runProcessX (proc ssExecutable $ "s" : args) ""
where return $ if rc == ExitSuccess then not st else st
args s = if s then ["off", "-dpms"] else ["on", "+dpms"]
query :: IO SSState query :: IO SSState
query = do query = do
-- TODO bracket the display
dpy <- openDisplay "" dpy <- openDisplay ""
xssi <- xScreenSaverQueryInfo dpy xssi <- xScreenSaverQueryInfo dpy
closeDisplay dpy closeDisplay dpy

View File

@ -21,13 +21,17 @@ module XMonad.Internal.IO
-- , isWritable -- , isWritable
, PermResult(..) , PermResult(..)
, getPermissionsSafe , getPermissionsSafe
, waitUntilExit
) where ) where
import Data.Char import Data.Char
import Data.Text (pack, unpack) import Data.Text (pack, unpack)
import Data.Text.IO as T (readFile, writeFile) import Data.Text.IO as T (readFile, writeFile)
import System.Directory import RIO
import RIO.Directory
import RIO.FilePath
import System.IO.Error import System.IO.Error
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
@ -124,3 +128,13 @@ getPermissionsSafe f = do
-- isWritable :: FilePath -> IO (PermResult Bool) -- isWritable :: FilePath -> IO (PermResult Bool)
-- isWritable = fmap (fmap writable) . getPermissionsSafe -- 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

View File

@ -1,75 +1,17 @@
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Functions for managing processes -- | Functions for managing processes
module XMonad.Internal.Process module XMonad.Internal.Process where
( waitUntilExit
-- , killHandle
-- , spawnPipe'
-- , spawnPipe
-- , spawnPipeArgs
, createProcess'
, readCreateProcessWithExitCode'
, proc'
, shell'
, spawn
, spawnAt
, module System.Process
) where
import Control.Concurrent -- import Control.Exception
import Control.Exception -- import Control.Monad
import Control.Monad -- import Control.Monad.IO.Class
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 XMonad.Core hiding (spawn)
import System.Exit
import System.IO
-- import System.Posix.Signals
import System.Process
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 }

View File

@ -6,9 +6,15 @@
module XMonad.Internal.Shell module XMonad.Internal.Shell
( fmtCmd ( fmtCmd
, spawnCmd , spawnCmd
, spawn
, doubleQuote , doubleQuote
, singleQuote , singleQuote
, skip , skip
, runProcessX
, spawnAt
, proc'
, shell'
, createProcess'
, (#!&&) , (#!&&)
, (#!||) , (#!||)
, (#!|) , (#!|)
@ -17,13 +23,46 @@ module XMonad.Internal.Shell
import Control.Monad.IO.Class import Control.Monad.IO.Class
import RIO
import qualified RIO.Text as T import qualified RIO.Text as T
import XMonad.Internal.Process import System.Process
import qualified XMonad.Core as X
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Opening subshell -- | 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 :: MonadIO m => FilePath -> [T.Text] -> m ()
spawnCmd cmd args = spawn $ T.unpack $ fmtCmd cmd args spawnCmd cmd args = spawn $ T.unpack $ fmtCmd cmd args