REF get rid of internal proc module
This commit is contained in:
parent
246208e3cf
commit
70541ca5b1
|
@ -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"
|
||||||
|
|
|
@ -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]
|
||||||
|
|
|
@ -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
|
||||||
|
|
||||||
|
|
|
@ -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
|
||||||
|
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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 }
|
|
||||||
|
|
|
@ -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
|
||||||
|
|
||||||
|
|
Loading…
Reference in New Issue