242 lines
8.4 KiB
Haskell
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
|