xman/app/Main.hs

--------------------------------------------------------------------------------
-- Xcape MANager (XMan) - a wrapper for managing xcape
--
-- xcape is a program to map keyrelease events to keysyms, and is very useful
-- for making custom keymaps. However, it is not always desirable to have this
-- running all the time; for example, VirtualBox will blend the xkb keymap with
-- that if the Guest OS, so xcape may end up producing an extra keypress. The
-- solution is to turn off xcape when certain windows are in focus.
--
-- The process for doing this using Xlib:
-- 1) Listen for PropertyNotify events from the root window
-- 2) Of those events, filter those where the _NET_ACTIVE_WINDOW atom has changed
-- 3) Using the value of _NET_ACTIVE_WINDOW, get the app name of the active window
-- 4) If the app name matches a certain criteria, turn off xcape (vice versa)
--
-- The matching criteria in (4) are POSIX regular expressions.
--
-- Known limitations:
-- this is agnostic to any keymap changes, so if the keymap is changed, xcape
-- will not be updated or restarted. Furthermore, it is outside the scope of
-- this program to bind multiple xcape mappings with multiple keymaps

module Main (main) where

import qualified Data.Text.IO as TI
import Graphics.X11.Types
import Graphics.X11.Xlib.Atom
import Graphics.X11.Xlib.Display
import Graphics.X11.Xlib.Event
import Graphics.X11.Xlib.Extras
import Graphics.X11.Xlib.Misc
import Graphics.X11.Xlib.Types
import RIO hiding (Display, display, handle)
import RIO.Directory
import RIO.State
import System.Environment
import System.Posix.IO
import System.Posix.Signals
import System.Process
import Text.Regex.TDFA

--------------------------------------------------------------------------------
-- Central State+Reader+IO Monad (I wonder where this idea came from...)
--
-- The Reader portion holds some of the key data structures from X that we care
-- about as well as the regular expression patterns to match the app names we
-- care about and and the bindings to pass to the xcape command.
--
-- The State portion holds the xcape process handle (so we can kill it later)

newtype XMan a = XMan (ReaderT XMConf (StateT XMState IO) a)
  deriving
    ( Functor
    , Applicative
    , Monad
    , MonadIO
    , MonadState XMState
    , MonadReader XMConf
    )

newtype XMState = XMState {xcapeHandle :: Maybe ProcessHandle}

data XMConf = XMConf
  { display :: Display
  , theRoot :: Window
  , netActiveWindow :: Atom
  , regexps :: Patterns
  , xcapeProcess :: CreateProcess
  }

-- | timeout for xcape
type Timeout = Maybe String

-- | bindings for xcape
type Bindings = String

-- | regular expression patterns
type Patterns = [String]

-- | window app name
type AppName = String

--------------------------------------------------------------------------------

main :: IO ()
main = getArgs >>= parse

-- | Given a list of arguments, either start the program or print the usage
parse :: [String] -> IO ()
parse [_] = usage
parse ("-t" : t : b : rs) = initXMan rs $ mkXcapeProcess (Just t) b
parse (b : rs) = initXMan rs $ mkXcapeProcess Nothing b
parse _ = usage

xcapeExe :: String
xcapeExe = "xcape"

-- | Given a timeout and bindings for xcape, return a process record. This will
-- run xcape in debug mode (which will make it run as a foreground process,
-- otherwise it will fork unnecessarily).
mkXcapeProcess :: Timeout -> Bindings -> CreateProcess
mkXcapeProcess (Just t) b = proc xcapeExe $ ["-t", t, "-d", "-e"] ++ [b]
mkXcapeProcess Nothing b = proc xcapeExe $ ["-d", "-e"] ++ [b]

-- | Print the usage and exit
usage :: IO ()
usage = TI.putStrLn "xman [-t TIMEOUT] BINDINGS REGEXP [[REGEXP] ...]"

-- | Given xcape bindings and regular expression patterns to match the window
-- titles we care about, initialize the XMan monad and run the main event loop
initXMan :: Patterns -> CreateProcess -> IO ()
initXMan rs cp = do
  r <- checkXcape
  if r then initX else TI.putStrLn "could not find xcape binary"
  where
    initX = do
      -- ignore SIGCHLD so we don't produce zombie processes
      void $ installHandler sigCHLD Ignore Nothing
      withDisplay $ \dpy -> do
        root <- rootWindow dpy $ defaultScreen dpy
        naw <- internAtom dpy "_NET_ACTIVE_WINDOW" False
        let cf =
              XMConf
                { display = dpy
                , theRoot = root
                , netActiveWindow = naw
                , regexps = rs
                , xcapeProcess = cp
                }
            st = XMState {xcapeHandle = Nothing}
        -- listen only for PropertyNotify events on the root window
        allocaSetWindowAttributes $ \a -> do
          set_event_mask a propertyChangeMask
          changeWindowAttributes dpy root cWEventMask a
        allocaXEvent $ \e ->
          runXMan cf st $ do
            updateXCape -- set the initial state before entering main loop
            forever $ handle =<< io (nextEvent dpy e >> getEvent e)

withDisplay :: MonadUnliftIO m => (Display -> m a) -> m a
withDisplay = bracket (liftIO $ openDisplay "") cleanup
  where
    cleanup dpy = liftIO $ do
      flush dpy
      closeDisplay dpy

checkXcape :: IO Bool
checkXcape = isJust <$> findExecutable xcapeExe

-- | Lift an IO monad into the XMan context
io :: MonadIO m => IO a -> m a
io = liftIO

-- | Given an initial state and configuration, run the XMan monad
runXMan :: XMConf -> XMState -> XMan a -> IO ()
runXMan c s (XMan a) = void $ runStateT (runReaderT a c) s

-- | Update the xcape status given the state of XMan
updateXCape :: XMan ()
updateXCape = do
  dpy <- asks display
  atom <- asks netActiveWindow
  root <- asks theRoot
  -- find the active window; if none are found, assume there are no windows
  -- open, in which case xcape should be running
  prop <- io $ getWindowProperty32 dpy atom root
  case prop of
    Just [aw] -> getAppName (fromIntegral aw) >>= startOrKillXCape
    _ -> startXCape

-- | Given an event, call a handler. In this case the only thing we care about
-- are PropertyNotify events where the atom is _NET_ACTIVE_WINDOW, which will
-- initiated the xcape update logic.
handle :: Event -> XMan ()
handle PropertyEvent {ev_atom = a} = do
  atom <- asks netActiveWindow
  when (a == atom) updateXCape
handle _ = return ()

-- | Given a window, return its app name
getAppName :: Window -> XMan AppName
getAppName w =
  io . fmap resName . permitBadWindow . flip getClassHint w
    =<< asks display

-- | Given an IO action (which is assumed to call an XLib function that may
-- throw an error), attach an error handler before performing the action and
-- remove it after it completes. The error handler will ignore BadWindow errors
-- (which in this case are assumed to be benign since the _NET_ACTIVE_WINDOW
-- atom may refer to a non-existent window)
permitBadWindow :: IO a -> IO a
permitBadWindow action = do
  handler <- mkXErrorHandler $ \_ e ->
    getErrorEvent e >>= handleError >> return 0
  original <- _xSetErrorHandler handler
  res <- action
  void $ _xSetErrorHandler original
  return res
  where
    -- TODO also ignore badvalue errors?
    handleError ErrorEvent {ev_error_code = t}
      | fromIntegral t == badWindow = return ()
    handleError _ = TI.putStrLn "actual error"

-- | Given an app name, start or stop xcape if it matches any of the supplied
-- regular expressions in XMan
startOrKillXCape :: AppName -> XMan ()
startOrKillXCape name = do
  rs <- asks regexps
  if any (name =~) rs then stopXCape else startXCape

-- | Start xcape if it is not already running
startXCape :: XMan ()
startXCape = do
  pID <- gets xcapeHandle
  unless (isJust pID) $ do
    cp <- asks xcapeProcess
    h <- io $ createProcessNull cp
    modify $ \s -> s {xcapeHandle = Just h}
    io $ TI.putStrLn "started xcape"

-- | Stop xcape if it is running
stopXCape :: XMan ()
stopXCape = do
  pID <- gets xcapeHandle
  forM_ pID $ \p -> do
    io $ terminateProcess p
    modify $ \s -> s {xcapeHandle = Nothing}
    io $ TI.putStrLn "stopped xcape"

-- | Given a createProcess record, start the process with stderr and stdout
-- redirected to the null device
-- NOTE: use the process module here rather than the unix module. The latter has
-- the 'forkProcess' function which may fail if multiple instances of xcape are
-- started and killed in quick succession (Resource unavailable error).
createProcessNull :: CreateProcess -> IO ProcessHandle
createProcessNull cp = do
  fd <- openFd "/dev/null" ReadOnly Nothing defaultFileFlags
  dn <- UseHandle <$> fdToHandle fd
  (_, _, _, h) <- createProcess $ cp {std_err = dn, std_out = dn}
  return h