REF get rid of internal proc module

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"

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

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
 

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
 

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

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

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
+  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 = do
+  -- TODO bracket the display
   dpy <- openDisplay ""
   xssi <- xScreenSaverQueryInfo dpy
   closeDisplay dpy

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

lib/XMonad/Internal/Process.hs

@@ -1,75 +1,17 @@
 --------------------------------------------------------------------------------
 -- | 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 }

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