xmonad-config/lib/XMonad/Internal/Shell.hs

{-# LANGUAGE OverloadedStrings #-}

-- Functions for formatting and spawning shell commands

module XMonad.Internal.Shell
  ( fmtCmd
  , spawnCmd
  , spawn
  , spawnPipe
  , doubleQuote
  , singleQuote
  , skip
  , runProcess
  , proc
  , shell
  , (#!&&)
  , (#!||)
  , (#!|)
  , (#!>>)
  )
where

import RIO
import qualified RIO.Text as T
import System.IO hiding (hSetBuffering)
import System.Posix.IO
import System.Posix.Process
import qualified System.Process.Typed as P
import qualified XMonad.Core as X

-- import qualified XMonad.Util.Run as XR

-- | Fork a new process and wait for its exit code.
--
-- This function will work despite xmonad ignoring SIGCHLD.
--
-- A few facts about xmonad (and window managers in general):
-- 1) It is single-threaded (since X is single threaded)
-- 2) Because of (1), it ignores SIGCHLD, which means any subprocess started
--    by xmonad will instantly be reaped after spawning. This guarantees the
--    main thread running the WM will never be blocked.
--
-- In general, this means I can't wait for exit codes (since wait() doesn't
-- work) See https://github.com/xmonad/xmonad/issues/113.
--
-- If I want an exit code, The best solution (I can come up with), is to use
-- bracket to uninstall handlers, run process (with wait), and then reinstall
-- handlers. I can use this with a much higher-level interface which will make
-- things easier. This obviously means that if the process is running in the
-- main thread, it needs to be almost instantaneous. Note if using a high-level
-- API for this, the process needs to spawn, finish, and be reaped by the
-- xmonad process all while the signal handlers are 'disabled' (which limits
-- the functions I can use to those that call waitForProcess).
--
-- XMonad and contrib use their own method of spawning subprocesses using the
-- extremely low-level 'System.Process.Posix' API. See the code for
-- 'XMonad.Core.spawn' or 'XMonad.Util.Run.safeSpawn'. Specifically, the
-- sequence is (in terms of the low level Linux API):
-- 1) call fork()
-- 2) uninstall signal handlers (to allow wait() to work in subprocesses)
-- 3) call setsid() (so killing the child will kill its children, if any)
-- 4) start new thing with exec()
--
-- In contrast with high-level APIs like 'System.Process', this will leave no
-- trailing data structures to clean up, at the cost of being gross to look at
-- and possibly more error-prone.
runProcess :: MonadUnliftIO m => P.ProcessConfig a b c -> m ExitCode
runProcess = withDefaultSignalHandlers . P.runProcess

-- | Run an action without xmonad's signal handlers.
withDefaultSignalHandlers :: MonadUnliftIO m => m a -> m a
withDefaultSignalHandlers =
  bracket_ X.uninstallSignalHandlers X.installSignalHandlers

-- | Set a child process to create a new group and session
addGroupSession :: P.ProcessConfig x y z -> P.ProcessConfig x y z
addGroupSession = P.setCreateGroup True . P.setNewSession True

-- | Create a 'ProcessConfig' for a shell command
shell :: T.Text -> P.ProcessConfig () () ()
shell = addGroupSession . P.shell . T.unpack

-- | Create a 'ProcessConfig' for a command with arguments
proc :: FilePath -> [T.Text] -> P.ProcessConfig () () ()
proc cmd args = addGroupSession $ P.proc cmd (T.unpack <$> args)

-- | Run 'XMonad.Core.spawn' with 'Text' input.
spawn :: MonadIO m => T.Text -> m ()
spawn = X.spawn . T.unpack

-- | Run 'XMonad.Run.Utils.spawnPipe' with 'Text' input.
spawnPipe
  :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
  => T.Text
  -> m Handle
spawnPipe = liftIO . spawnPipeRW

spawnPipeRW :: T.Text -> IO Handle
spawnPipeRW x = do
  (rI, wI) <- createPipe
  -- (rO, wO) <- createPipe
  -- I'm assuming the only place this matters is when xmonad is restarted (which
  -- calls exec); since these are the ends of the pipe that xmonad will be
  -- using, this ensures they will be closed when restarting
  err <- dup stdError
  forM_ [wI, err] $ \fd -> setFdOption fd CloseOnExec True
  h <- mkHandle wI
  void $ X.xfork $ do
    void $ dupTo rI stdInput
    void $ dupTo err stdOutput
    void $ dupTo err stdError
    executeFile "/bin/sh" False ["-c", T.unpack x] Nothing
  closeFd rI
  return h
  where
    mkHandle fd = do
      h <- fdToHandle fd
      -- ASSUME we are using utf8 everywhere
      hSetEncoding h utf8
      hSetBuffering h LineBuffering
      return h

-- | Run 'XMonad.Core.spawn' with a command and arguments
spawnCmd :: MonadIO m => FilePath -> [T.Text] -> m ()
spawnCmd cmd = spawn . fmtCmd cmd

-- | Format a command and list of arguments as 'Text'
fmtCmd :: FilePath -> [T.Text] -> T.Text
fmtCmd cmd args = T.unwords $ T.pack cmd : args

op :: T.Text -> T.Text -> T.Text -> T.Text
op a x b = T.unwords [a, x, b]

-- | Format two shell expressions separated by "&&"
(#!&&) :: T.Text -> T.Text -> T.Text
cmdA #!&& cmdB = op cmdA "&&" cmdB

infixr 0 #!&&

-- | Format two shell expressions separated by "|"
(#!|) :: T.Text -> T.Text -> T.Text
cmdA #!| cmdB = op cmdA "|" cmdB

infixr 0 #!|

-- | Format two shell expressions separated by "||"
(#!||) :: T.Text -> T.Text -> T.Text
cmdA #!|| cmdB = op cmdA "||" cmdB

infixr 0 #!||

-- | Format two shell expressions separated by ";"
(#!>>) :: T.Text -> T.Text -> T.Text
cmdA #!>> cmdB = op cmdA ";" cmdB

infixr 0 #!>>

-- | Wrap input in double quotes
doubleQuote :: T.Text -> T.Text
doubleQuote s = T.concat ["\"", s, "\""]

-- | Wrap input in single quotes
singleQuote :: T.Text -> T.Text
singleQuote s = T.concat ["'", s, "'"]

skip :: Monad m => m ()
skip = return ()