1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
|
-- | Key and mouse bindings that run commands, read from a JSON file at
-- runtime, so they can be changed without rebuilding xmonad.
--
-- The file is @$XDG_CONFIG_HOME/xmonad/bindings.json@ (usually
-- @~/.config/xmonad/bindings.json@):
--
-- > {
-- > "groups": [
-- > { "group": "Volume",
-- > "keys": [
-- > { "key": "XF86AudioRaiseVolume", "run": "pactl set-sink-volume @DEFAULT_SINK@ +2dB" }
-- > ] },
-- > { "group": "Open the last selection",
-- > "comment": "optional everywhere, ignored",
-- > "keys": [ { "key": "M-o", "launch": "xdg-open \"$(xclip -selection primary -out)\"" } ],
-- > "buttons": [ { "button": "M-2", "launch": "xdg-open \"$(xclip -selection primary -out)\"" } ] }
-- > ]
-- > }
--
-- Groups are only for reading the file (and for the error messages); every
-- trigger must still be unique across all of them. A group has @keys@,
-- @buttons@, or both.
--
-- A trigger is zero or more modifiers, each followed by @-@, then an X
-- keysym name (as in @xev@ or @/usr/include/X11/keysymdef.h@, without
-- @XK_@) or a mouse button number. Modifiers: @M@ (Mod4), @C@ (Control),
-- @S@ (Shift), @A@ (Mod1). Keys are matched by keycode, like xbindkeys did:
-- @M-t@ and @M-T@ mean the same key, without Shift.
--
-- @run@ hands the command to @/bin/sh -c@, for things that finish quickly.
-- @launch@ does the same inside its own transient systemd scope
-- (@app-xmonad-<word>-<n>.scope@ in @app.slice@), for programs that stay
-- around, so they get their own cgroup and journal unit.
--
-- A binding in this file wins over a built-in xmonad binding on the same
-- key; the built-in ones are what is left when the file does not exist.
--
-- Reload after editing (keeps the old bindings and sends a notification if
-- the new file is broken):
--
-- > pkill --signal HUP --exact --uid "$UID" .xmonad-wrapped
--
-- Every file that loads is copied to
-- @$XDG_STATE_HOME/xmonad/bindings.last-good.json@. If the file is broken
-- when xmonad starts, that copy is used instead, with a critical
-- notification naming the error and the copy's age. Without a copy, only
-- the built-in keys work (also with a critical notification).
--
-- Check a file without loading it:
--
-- > xmonad --check-bindings [file]
module Bindings
( bindingsStartupHook,
bindingsEventHook,
launchApp,
checkBindingsMain,
)
where
import Control.Exception qualified as Exception
import Control.Monad (forM, unless, void, when)
import Data.Aeson ((.!=), (.:), (.:?))
import Data.Aeson qualified as Json
import Data.Aeson.Key qualified as Json.Key
import Data.Aeson.KeyMap qualified as Json.KeyMap
import Data.Aeson.Types qualified as Json.Types
import Data.Bifunctor (first)
import Data.Bits ((.&.))
import Data.ByteString qualified as ByteString
import Data.Char (isAlphaNum)
import Data.Either (partitionEithers)
import Data.Foldable (for_)
import Data.List (intercalate)
import Data.Map.Strict qualified as Map
import Data.Monoid (All (..))
import GHC.Clock (getMonotonicTimeNSec)
import Data.Time.Format (defaultTimeLocale, formatTime)
import Data.Time.LocalTime (utcToLocalZonedTime)
import Numeric (showHex)
import System.Directory
( XdgDirectory (XdgConfig, XdgState),
createDirectoryIfMissing,
doesFileExist,
getModificationTime,
getXdgDirectory,
renameFile,
)
import System.Exit (exitFailure)
import System.FilePath (takeDirectory, (</>))
import System.IO (hPutStrLn, stderr)
import System.Posix.Signals (Handler (Catch), installHandler, sigHUP)
import XMonad
import XMonad.Util.ExtensibleState qualified as XS
import XMonad.Util.Run (safeSpawn)
data BindAction
= -- | @/bin/sh -c@
ActRun String
| -- | @/bin/sh -c@ in its own systemd scope
ActLaunch String
deriving stock (Show)
-- | The bindings loaded from the file, plus the keycodes they are
-- currently grabbed as (which depend on the keyboard mapping).
data Bindings = Bindings
{ keyBinds :: [((KeyMask, KeySym), BindAction)],
buttonBinds :: Map.Map (ButtonMask, Button) BindAction,
grabbedKeys :: Map.Map (KeyMask, KeyCode) BindAction
}
noBindings :: Bindings
noBindings = Bindings {keyBinds = [], buttonBinds = Map.empty, grabbedKeys = Map.empty}
instance ExtensionClass Bindings where
initialValue = noBindings
-- | Install the SIGHUP handler and load the file.
bindingsStartupHook :: X ()
bindingsStartupHook = do
installReloadSignal
reloadBindings Startup
-- | Must be part of 'handleEventHook'. Returns @All False@ for every event
-- it handled, so xmonad's default handler does not see it.
bindingsEventHook :: Event -> X All
bindingsEventHook = \case
KeyEvent {ev_event_type = t, ev_state = m, ev_keycode = code}
| t == keyPress -> do
mClean <- cleanMask m
grabbed <- XS.gets @Bindings (.grabbedKeys)
runIfBound (Map.lookup (mClean, code) grabbed)
ButtonEvent {ev_event_type = t, ev_window = w, ev_state = m, ev_button = b}
| t == buttonPress -> do
-- our grabs are on the root window; presses on clients are
-- xmonad's click-to-focus
isr <- isRoot w
-- drop the state of other, already pressed buttons
mClean <- cleanMask (m .&. (button1Mask - 1))
binds <- XS.gets @Bindings (.buttonBinds)
if isr then runIfBound (Map.lookup (mClean, b) binds) else pure (All True)
ClientMessageEvent {ev_message_type = mt} -> do
reloadAtom <- getAtom reloadAtomName
if mt == reloadAtom
then reloadBindings Reload >> pure (All False)
else pure (All True)
-- Replaces xmonad's own handler, which would only grab its own keys
-- again. Happens on every setxkbmap.
e@MappingNotifyEvent {} -> do
io (refreshKeyboardMapping e)
when (ev_request e `elem` [mappingKeyboard, mappingModifier]) $ do
cacheNumlockMask
regrab
pure (All False)
_ -> pure (All True)
where
runIfBound = \case
Nothing -> pure (All True)
Just action -> runAction action >> pure (All False)
-- | Releases the grab the key press activated first, otherwise programs
-- that grab keyboard or pointer themselves (import, lock-screen) fail.
runAction :: BindAction -> X ()
runAction action = do
unGrab
case action of
ActRun cmd -> spawn cmd
ActLaunch cmd -> launchApp cmd
-- | Run a shell command in its own transient systemd user scope.
launchApp :: String -> X ()
launchApp cmd = do
stamp <- io getMonotonicTimeNSec
let unit = "app-xmonad-" <> unitWord <> "-" <> showHex stamp "" <> ".scope"
safeSpawn
"systemd-run"
[ "--user",
"--scope",
"--slice=app.slice",
"--collect",
"--quiet",
"--unit=" <> unit,
"--description=" <> cmd,
"--",
"/bin/sh",
"-c",
cmd
]
where
-- the program name, as far as it is allowed in a unit name
unitWord =
case filter (\c -> isAlphaNum c || c == '_' || c == '-') (baseName (takeWhile (/= ' ') cmd)) of
"" -> "cmd"
w -> take 32 w
baseName = reverse . takeWhile (/= '/') . reverse
-- * Loading
reloadAtomName :: String
reloadAtomName = "PROFPATSCH_XMONAD_RELOAD_BINDINGS"
-- | The handler only wakes up the event loop: it runs in its own thread,
-- while the bindings live in the X monad. Needs the threaded runtime,
-- otherwise it would wait for the event loop's blocking XNextEvent.
installReloadSignal :: X ()
installReloadSignal = io $ void $ installHandler sigHUP (Catch sendReloadMessage) Nothing
sendReloadMessage :: IO ()
sendReloadMessage =
Exception.handle (\(e :: Exception.SomeException) -> hPutStrLn stderr ("bindings: SIGHUP: " <> show e)) $
Exception.bracket (openDisplay "") closeDisplay $ \dpy -> do
let root = defaultRootWindow dpy
atom <- internAtom dpy reloadAtomName False
allocaXEvent $ \ev -> do
setEventType ev clientMessage
setClientMessageEvent' ev root atom 32 []
sendEvent dpy root False structureNotifyMask ev
sync dpy False
bindingsPath :: IO FilePath
bindingsPath = (</> "bindings.json") <$> getXdgDirectory XdgConfig "xmonad"
-- | Every file that loaded is copied here, so a broken file at startup
-- does not leave the session without its bindings.
lastGoodPath :: IO FilePath
lastGoodPath = (</> "bindings.last-good.json") <$> getXdgDirectory XdgState "xmonad"
data Why = Startup | Reload
-- | A broken file on reload keeps the bindings we have. At startup there are
-- none yet, so it falls back to the last good copy instead.
reloadBindings :: Why -> X ()
reloadBindings why = do
path <- io bindingsPath
lastGood <- io lastGoodPath
io (readBindingsFile path) >>= \case
Loaded binds bytes -> do
install binds
io (saveLastGood lastGood bytes)
trace ("bindings: loaded " <> summary binds)
case why of
Reload -> notify "low" "xmonad: bindings reloaded" (summary binds)
Startup -> pure ()
Missing -> do
trace ("bindings: " <> path <> " does not exist, no extra bindings")
install noBindings
Broken err -> case why of
Reload -> do
trace ("bindings: keeping the previous bindings: " <> err)
notify "critical" "xmonad: bindings NOT reloaded, kept the old ones" err
Startup ->
io (readBindingsFile lastGood) >>= \case
Loaded binds _ -> do
install binds
age <- io (formatModificationTime lastGood)
trace ("bindings: " <> err <> "\nbindings: using " <> lastGood <> " from " <> age)
notify
"critical"
("xmonad: bindings.json is BROKEN, using the copy from " <> age)
(err <> "\n\nFix it, then reload:\npkill --signal HUP --exact --uid \"$UID\" .xmonad-wrapped")
other -> do
let why' = case other of
Broken cacheErr -> cacheErr
_ -> lastGood <> " does not exist"
trace ("bindings: " <> err <> "\nbindings: no last good copy: " <> why')
install noBindings
notify
"critical"
"xmonad: bindings.json is BROKEN, only the built-in keys work"
(err <> "\n\nNo last good copy: " <> why')
where
install binds = XS.put binds >> regrab
-- | Retries for a while: at startup the notification daemon may not be up
-- yet. Critical notifications stay until dismissed.
--
-- TODO: if the daemon never comes up (dunst has failed to start before),
-- the warning is only in the journal. A fallback that does not depend on
-- the notification daemon would be better (e.g. 'xmessage', pinned into
-- the wrapper, after the retries fail).
notify :: String -> String -> String -> X ()
notify urgency heading body =
safeSpawn
"/bin/sh"
[ "-c",
"for i in $(seq 30); do notify-send --urgency=\"$1\" --app-name=xmonad \"$2\" \"$3\" && exit 0; sleep 1; done",
"notify",
urgency,
heading,
body
]
-- | Only writes if the content changed; atomically, so a crash cannot
-- leave a half-written copy.
saveLastGood :: FilePath -> ByteString.ByteString -> IO ()
saveLastGood path bytes =
Exception.handle (\(e :: Exception.IOException) -> hPutStrLn stderr ("bindings: could not save " <> path <> ": " <> show e)) $ do
old <- Exception.try @Exception.IOException (ByteString.readFile path)
unless (either (const False) (== bytes) old) $ do
createDirectoryIfMissing True (takeDirectory path)
ByteString.writeFile (path <> ".tmp") bytes
renameFile (path <> ".tmp") path
formatModificationTime :: FilePath -> IO String
formatModificationTime path =
Exception.try @Exception.IOException (getModificationTime path) >>= \case
Left _ -> pure "an unknown time"
Right t -> formatTime defaultTimeLocale "%Y-%m-%d %H:%M" <$> utcToLocalZonedTime t
summary :: Bindings -> String
summary b = show (length b.keyBinds) <> " keys, " <> show (Map.size b.buttonBinds) <> " buttons"
-- | Ungrab everything on the root window, then grab xmonad's own keys and
-- buttons (like its startup does) and ours. Keysyms are turned into
-- keycodes here, because they depend on the current keyboard mapping.
regrab :: X ()
regrab = withDisplay $ \dpy -> do
root <- asks theRoot
extraMods <- extraModifiers
let grabK m code = for_ extraMods $ \extra ->
io $ grabKey dpy code (m .|. extra) root True grabModeAsync grabModeAsync
grabB kbdMode m b = for_ extraMods $ \extra ->
io $ grabButton dpy b (m .|. extra) root False buttonPressMask grabModeAsync kbdMode none none
io $ ungrabKey dpy anyKey anyModifier root
xmonadKeys <- mkGrabs =<< asks (Map.keys . keyActions)
for_ xmonadKeys $ \(m, code) ->
io $ grabKey dpy code m root True grabModeAsync grabModeAsync
binds <- XS.get @Bindings
resolved <- io $ forM binds.keyBinds $ \((m, sym), action) -> do
code <- keysymToKeycode dpy sym
pure (if code == 0 then Left (keysymToString sym) else Right ((m, code), action))
let (unmapped, ours) = partitionEithers resolved
grabbed = Map.fromList ours
unless (null unmapped) $
trace ("bindings: not on the current keyboard, not grabbed: " <> unwords unmapped)
for_ (Map.keys grabbed) (uncurry grabK)
XS.put binds {grabbedKeys = grabbed}
io $ ungrabButton dpy anyButton anyModifier root
xmonadButtons <- asks (Map.keys . buttonActions)
-- the keyboard mode xmonad uses for its own button grabs
for_ xmonadButtons (uncurry (grabB grabModeSync))
for_ (Map.keys binds.buttonBinds) (uncurry (grabB grabModeAsync))
data Loaded
= Missing
| Broken String
| -- | with the bytes it was parsed from, for the last good copy
Loaded Bindings ByteString.ByteString
-- | Reads the file once, so the last good copy is exactly what was parsed.
readBindingsFile :: FilePath -> IO Loaded
readBindingsFile path =
doesFileExist path >>= \case
False -> pure Missing
True ->
Exception.try @Exception.IOException (ByteString.readFile path) <&> \case
Left e -> Broken (path <> ": " <> show e)
Right bytes ->
case first ((path <> ": ") <>) (parseBytes bytes) of
Left err -> Broken err
Right binds -> Loaded binds bytes
where
(<&>) = flip fmap
parseBytes bytes = do
value <- Json.eitherDecodeStrict bytes
entries <- Json.Types.parseEither parseFile value
fromEntries entries
data Entry = Entry {group :: String, trigger :: String, action :: BindAction}
-- | Returns (keys, buttons) of all groups.
parseFile :: Json.Value -> Json.Types.Parser ([Entry], [Entry])
parseFile = Json.withObject "bindings file" $ \o -> do
noUnknownFields ["groups", "comment"] o
groups <- indexed o "groups" parseGroup
pure (concatMap fst groups, concatMap snd groups)
parseGroup :: Json.Value -> Json.Types.Parser ([Entry], [Entry])
parseGroup = Json.withObject "group" $ \o -> do
noUnknownFields ["group", "keys", "buttons", "comment"] o
name <- o .: "group"
ks <- indexed o "keys" (parseEntry name "key")
bs <- indexed o "buttons" (parseEntry name "button")
when (null ks && null bs) $ fail ("group " <> show name <> " has neither keys nor buttons")
pure (ks, bs)
-- | An optional list field, each element parsed with its position in the
-- error path (@$.groups[2].keys[0]@).
indexed :: Json.Object -> Json.Key -> (Json.Value -> Json.Types.Parser a) -> Json.Types.Parser [a]
indexed o field p = do
vs :: [Json.Value] <- o .:? field .!= []
sequence [p v Json.Types.<?> Json.Types.Index i | (i, v) <- zip [0 ..] vs]
Json.Types.<?> Json.Types.Key field
parseEntry :: String -> Json.Key -> Json.Value -> Json.Types.Parser Entry
parseEntry group triggerField = Json.withObject "binding" $ \o -> do
noUnknownFields [triggerField, "run", "launch", "comment"] o
trigger <- o .: triggerField
run <- o .:? "run"
launch' <- o .:? "launch"
action <- case (run, launch') of
(Just cmd, Nothing) -> pure (ActRun cmd)
(Nothing, Just cmd) -> pure (ActLaunch cmd)
_ -> fail "needs exactly one of \"run\" and \"launch\""
pure Entry {..}
noUnknownFields :: [Json.Key] -> Json.Object -> Json.Types.Parser ()
noUnknownFields allowed o =
case filter (`notElem` allowed) (Json.KeyMap.keys o) of
[] -> pure ()
unknown -> fail ("unknown fields: " <> intercalate ", " (map Json.Key.toString unknown))
-- | Reports all problems at once, not just the first.
fromEntries :: ([Entry], [Entry]) -> Either String Bindings
fromEntries (ks, bs) =
let (keyErrs, keyOk) = partitionEithers [annotate "key" e (resolveKey e.trigger) | e <- ks]
(buttonErrs, buttonOk) = partitionEithers [annotate "button" e (resolveButton e.trigger) | e <- bs]
errs =
keyErrs
<> buttonErrs
<> duplicates "key" [(k, e) | (k, e) <- keyOk]
<> duplicates "button" [(k, e) | (k, e) <- buttonOk]
in if null errs
then
Right
noBindings
{ keyBinds = [(k, e.action) | (k, e) <- keyOk],
buttonBinds = Map.fromList [(k, e.action) | (k, e) <- buttonOk]
}
else Left (intercalate "\n" errs)
where
annotate what e = either (\err -> Left (describe what e <> ": " <> err)) (\k -> Right (k, e))
-- | @group "Volume", key "M-t"@
describe :: String -> Entry -> String
describe what e = "group " <> show e.group <> ", " <> what <> " " <> show e.trigger
duplicates :: (Ord k) => String -> [(k, Entry)] -> [String]
duplicates what xs =
[ what <> " bound more than once: " <> intercalate "; " (map (describe what) es)
| es <- Map.elems (Map.fromListWith (flip (<>)) [(k, [e]) | (k, e) <- xs]),
length es > 1
]
resolveKey :: String -> Either String (KeyMask, KeySym)
resolveKey t = do
(m, name) <- parseTrigger t
let sym = stringToKeysym name
when (sym == noSymbol) $ Left ("unknown keysym " <> show name)
pure (m, sym)
resolveButton :: String -> Either String (ButtonMask, Button)
resolveButton t = do
(m, name) <- parseTrigger t
case reads name of
[(b, "")] | b >= 1 && b <= 255 -> pure (m, b)
_ -> Left ("not a button number: " <> show name)
-- | @"M-C-d"@ → @(mod4Mask .|. controlMask, "d")@
parseTrigger :: String -> Either String (KeyMask, String)
parseTrigger t = case splitOn t of
parts | null (last parts) -> Left "nothing after the last \"-\""
parts -> do
mods <- traverse modifier (init parts)
pure (foldr (.|.) 0 mods, last parts)
where
modifier = \case
"M" -> Right mod4Mask
"C" -> Right controlMask
"S" -> Right shiftMask
"A" -> Right mod1Mask
m -> Left ("unknown modifier " <> show m <> " (known: M C S A)")
splitOn s = case break (== '-') s of
(a, []) -> [a]
(a, _ : rest) -> a : splitOn rest
-- | @xmonad --check-bindings [file]@
checkBindingsMain :: [String] -> IO ()
checkBindingsMain args = do
path <- case args of
[p] -> pure p
[] -> bindingsPath
_ -> hPutStrLn stderr "usage: xmonad --check-bindings [file]" >> exitFailure
readBindingsFile path >>= \case
Broken err -> hPutStrLn stderr err >> exitFailure
Missing -> hPutStrLn stderr (path <> ": does not exist") >> exitFailure
Loaded b _ -> putStrLn (path <> ": " <> summary b)
|