ndwarshuis
/
xmonad-config
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

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
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
bin/vbox-start.hs
View File

@ -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"

33
bin/xmobar.hs
View File

@ -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) "")
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 "
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.pack err]
go (Left e) = Just $ Msg LevelError $ T.pack $ show e
, T.decodeUtf8With T.lenientDecode
$ BL.toStrict err
]
where
args = ["-c", "no", "-t", "-f", "TYPE", "c", "show"]
--------------------------------------------------------------------------------
-- | 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]

2
lib/XMonad/Internal/Command/DMenu.hs
View File

@ -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

1
lib/XMonad/Internal/Command/Desktop.hs
View File

@ -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

2
lib/XMonad/Internal/Command/Power.hs
View File

@ -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

4
lib/XMonad/Internal/Concurrent/DynamicWorkspaces.hs
View File

@ -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

18
lib/XMonad/Internal/DBus/Screensaver.hs
View File

@ -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

16
lib/XMonad/Internal/IO.hs
View File

@ -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 System.Directory
import RIO
import RIO.Directory
import RIO.FilePath
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

76
lib/XMonad/Internal/Process.hs
View File

@ -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 }

41
lib/XMonad/Internal/Shell.hs
View File

@ -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 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