xman/app/Main.hs

242 lines
8.4 KiB
Haskell

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