xman/app/Main.hs

246 lines
8.9 KiB
Haskell
Raw Normal View History

2020-03-31 23:15:43 -04:00
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
2020-04-01 12:57:39 -04:00
--------------------------------------------------------------------------------
2020-04-01 12:59:35 -04:00
-- | Xcape MANager (XMan) - a wrapper for managing xcape
2020-04-01 12:57:39 -04:00
--
2020-04-01 12:59:35 -04:00
-- 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.
2020-04-01 12:57:39 -04:00
--
-- 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 title of the active window
2020-04-01 12:59:35 -04:00
-- 4) If active window matches a certain criteria, turn off xcape (vice versa)
2020-04-01 12:57:39 -04:00
--
-- The matching criteria in (4) are POSIX regular expressions.
2020-04-01 13:02:17 -04:00
--
-- 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
2020-04-01 12:57:39 -04:00
2020-03-31 23:15:43 -04:00
module Main where
import Control.Monad (forM_, forever, void, when)
import Control.Monad.Reader
import Control.Monad.State
import Data.List (any)
import Data.Maybe (isJust)
import Foreign.C.String (castCCharToChar)
import Foreign.C.Types (CLong)
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 Text.Regex.TDFA
import System.Environment
import System.Posix.IO
import System.Posix.Signals
import System.Process
type WindowTitle = String
2020-04-01 12:57:39 -04:00
--------------------------------------------------------------------------------
-- | Central State+Reader+IO Monad (I wonder where this idea came from...)
--
2020-04-01 12:59:35 -04:00
-- 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 and the keys to
-- pass the xcape command.
2020-04-01 12:57:39 -04:00
--
2020-04-01 12:59:35 -04:00
-- The State portion holds the xcape process handle (so we can kill it later)
2020-04-01 12:57:39 -04:00
-- and the current window title.
2020-03-31 23:15:43 -04:00
newtype XMan a = XMan (ReaderT XMConf (StateT XMState IO) a) deriving
(Functor, Monad, MonadIO, MonadState XMState, MonadReader XMConf)
instance Applicative XMan where
pure = return
(<*>) = ap
data XMState = XMState
{ currentTitle :: Maybe WindowTitle
, xcapeProcess :: Maybe ProcessHandle
}
data XMConf = XMConf
{ display :: Display
, theRoot :: Window
, netActiveWindow :: Atom
, netWMName :: Atom
, regexps :: [String]
, xcapeKeys :: String
}
2020-04-01 13:02:17 -04:00
--------------------------------------------------------------------------------
2020-04-01 12:57:39 -04:00
main :: IO ()
main = getArgs >>= parse
2020-03-31 23:15:43 -04:00
2020-04-01 12:57:39 -04:00
-- | Given a list of arguments, either start the program or print the usage
2020-03-31 23:15:43 -04:00
parse :: [String] -> IO ()
parse [_] = usage
parse (x:rs) = initXMan x rs
parse _ = usage
2020-04-01 12:57:39 -04:00
-- | Print the usage and exit
2020-03-31 23:15:43 -04:00
usage :: IO ()
2020-04-01 12:57:39 -04:00
-- TODO produce relevant exit codes here
2020-03-31 23:15:43 -04:00
usage = putStrLn "xman XCAPE_KEYS REGEXP [[REGEXP]...]"
2020-04-01 12:57:39 -04:00
-- | Given a string of keys for xcape and a list of regular expressions to match
-- the window titles we care about, initialize the XMan monad and run the main
-- event loop.
2020-03-31 23:15:43 -04:00
initXMan :: String -> [String] -> IO ()
initXMan x r = do
2020-04-01 12:57:39 -04:00
-- ignore SIGCHLD so we don't produce zombie processes
2020-03-31 23:15:43 -04:00
void $ installHandler sigCHLD Ignore Nothing
dpy <- openDisplay ""
root <- rootWindow dpy $ defaultScreen dpy
naw <- internAtom dpy "_NET_ACTIVE_WINDOW" False
nwn <- internAtom dpy "_NET_WM_NAME" False
let cf = XMConf
{ display = dpy
, theRoot = root
, netActiveWindow = naw
, netWMName = nwn
, regexps = r
, xcapeKeys = x
}
st = XMState { currentTitle = Nothing, xcapeProcess = Nothing }
2020-04-01 12:57:39 -04:00
-- listen only for PropertyNotify events on the root window
2020-03-31 23:15:43 -04:00
allocaSetWindowAttributes $ \a -> do
set_event_mask a propertyChangeMask
changeWindowAttributes dpy root cWEventMask a
void $ allocaXEvent $ \e ->
runXMan cf st $ do
2020-04-01 12:57:39 -04:00
updateXCape -- set the initial state before entering main loop
2020-03-31 23:15:43 -04:00
forever $ handle =<< io (nextEvent dpy e >> getEvent e)
2020-04-01 12:57:39 -04:00
-- | 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 (a, XMState)
runXMan c s (XMan a) = runStateT (runReaderT a c) s
-- | Update the xcape status given the state of XMan
2020-03-31 23:15:43 -04:00
updateXCape :: XMan ()
updateXCape = do
dpy <- asks display
atom <- asks netActiveWindow
root <- asks theRoot
prop <- io $ getWindowProperty32 dpy atom root
case prop of
Just [aw] -> getTitle aw >>= updateTitle >> startOrKillXCape
_ -> return ()
2020-04-01 12:57:39 -04:00
-- | 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.
2020-03-31 23:15:43 -04:00
handle :: Event -> XMan ()
handle PropertyEvent { ev_atom = a } = do
atom <- asks netActiveWindow
when (a == atom) updateXCape
handle _ = return ()
2020-04-01 12:57:39 -04:00
-- | Get the title of a window given a window ID
-- The window title could be in two atoms. This will try _NET_WM_NAME first
-- before trying WM_NAME (legacy)
2020-03-31 23:15:43 -04:00
getTitle :: CLong -> XMan (Maybe WindowTitle)
getTitle winID = do
nwn <- asks netWMName
doMaybe [nwn, wM_NAME] $ getTitle' winID
where
doMaybe (x:xs) f = f x >>= (\r -> if isJust r then return r else doMaybe xs f)
doMaybe [] _ = return Nothing
2020-04-01 12:57:39 -04:00
-- | Get the title of a window given a window ID and an atom that may contain
-- the title
2020-03-31 23:15:43 -04:00
getTitle' :: CLong -> Atom -> XMan (Maybe WindowTitle)
getTitle' winID atom = do
dpy <- asks display
title' <- io $ permitBadWindow $ getWindowProperty8 dpy atom
$ fromIntegral winID
return $ fmap (fmap castCCharToChar) title'
2020-04-01 12:57:39 -04:00
-- | 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)
2020-03-31 23:15:43 -04:00
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 _ = print "actual error"
2020-04-01 12:57:39 -04:00
-- | Given a window title that may exist, update the window title in XMan's
-- state
2020-03-31 23:15:43 -04:00
updateTitle :: Maybe WindowTitle -> XMan ()
updateTitle newTitle = modify (\s -> s { currentTitle = newTitle } )
2020-04-01 12:57:39 -04:00
-- | Start or stop xcape given the state in XMan
2020-03-31 23:15:43 -04:00
startOrKillXCape :: XMan ()
startOrKillXCape = do
2020-04-01 12:57:39 -04:00
-- TODO this is redundant
2020-03-31 23:15:43 -04:00
title <- gets currentTitle
case title of
Just t -> asks regexps >>= \r ->
if any (t =~) r then stopXCape else startXCape
Nothing -> startXCape
2020-04-01 12:59:35 -04:00
-- | Start xcape if it is not already running
2020-03-31 23:15:43 -04:00
startXCape :: XMan ()
startXCape = do
pID <- gets xcapeProcess
unless (isJust pID) $ do
x <- asks xcapeKeys
h <- io $ runXcape x
modify $ \s -> s { xcapeProcess = Just h }
io $ print "started xcape"
2020-04-01 12:59:35 -04:00
-- | Stop xcape if it is running
2020-03-31 23:15:43 -04:00
stopXCape :: XMan ()
stopXCape = do
pID <- gets xcapeProcess
forM_ pID $ \p -> do
io $ terminateProcess p
modify $ \s -> s { xcapeProcess = Nothing }
io $ print "stopped xcape"
2020-04-01 12:57:39 -04:00
-- | Given the keys argument for xcape, run xcape with the keys argument and
-- return the process handle. Run xcape in debug mode (this will make it run as
-- a foreground process, otherwise it will fork unnecessarily) and pipe the
-- output and error streams 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).
2020-03-31 23:15:43 -04:00
runXcape :: String -> IO ProcessHandle
runXcape keys = do
dn <- fmap UseHandle $ fdToHandle
=<< openFd "/dev/null" ReadOnly Nothing defaultFileFlags
2020-04-01 12:57:39 -04:00
-- TODO pass more arguments here? this hardcodes the timeout
2020-03-31 23:15:43 -04:00
let cp = proc "xcape" $ ["-d", "-t", "500", "-e"] ++ [keys]
(_, _, _, h) <- createProcess $ cp { std_err = dn, std_out = dn }
return h