forked from alphapapa/ement.el
-
Notifications
You must be signed in to change notification settings - Fork 0
/
Copy pathement-lib.el
1834 lines (1715 loc) · 98.2 KB
/
ement-lib.el
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
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
;;; ement-lib.el --- Library of Ement functions -*- lexical-binding: t; -*-
;; Copyright (C) 2022-2023 Free Software Foundation, Inc.
;; Author: Adam Porter <[email protected]>
;; Maintainer: Adam Porter <[email protected]>
;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with this program. If not, see <https://www.gnu.org/licenses/>.
;;; Commentary:
;; This library provides functions used in other Ement libraries. It exists so they may
;; be required where needed, without causing circular dependencies.
;;; Code:
;;;; Requirements
(eval-when-compile
(require 'eieio)
(require 'ewoc)
(require 'pcase)
(require 'subr-x)
(require 'taxy-magit-section)
(require 'ement-macros))
(require 'cl-lib)
(require 'button)
(require 'color)
(require 'map)
(require 'seq)
(require 'xml)
(require 'ement-api)
(require 'ement-structs)
;;;; Variables
(defvar ement-sessions)
(defvar ement-users)
(defvar ement-ewoc)
(defvar ement-room)
(defvar ement-session)
(defvar ement-room-buffer-name-prefix)
(defvar ement-room-buffer-name-suffix)
(defvar ement-room-leave-kill-buffer)
(defvar ement-room-prism)
(defvar ement-room-prism-color-adjustment)
(defvar ement-room-prism-minimum-contrast)
(defvar ement-room-unread-only-counts-notifications)
;;;; Function declarations
;; Instead of using top-level `declare-function' forms (which can easily become obsolete
;; if not kept with the code that needs them), this allows the use of `(declare (function
;; ...))' forms in each function definition, so that if a function is moved or removed,
;; the `declare-function' goes with it.
;; TODO: Propose this upstream.
(eval-and-compile
(defun ement--byte-run--declare-function (_name _args &rest values)
"Return a `declare-function' form with VALUES.
Allows the use of a form like:
(declare (function FN FILE ...))
inside of a function definition, effectively keeping its
`declare-function' form inside the function definition, ensuring
that stray such forms don't remain if the function is removed."
`(declare-function ,@values))
(cl-pushnew '(function ement--byte-run--declare-function) defun-declarations-alist :test #'equal)
(cl-pushnew '(function ement--byte-run--declare-function) macro-declarations-alist :test #'equal))
;;;; Compatibility
;; These workarounds should be removed when they aren't needed.
(defalias 'ement--json-parse-buffer
;; For non-libjansson builds (those that do have libjansson will see a 4-5x improvement
;; in the time needed to parse JSON responses).
;; TODO: Suggest mentioning in manual and docstrings that `json-read', et al do not use
;; libjansson, while `json-parse-buffer', et al do.
(if (fboundp 'json-parse-buffer)
(lambda ()
(condition-case err
(json-parse-buffer :object-type 'alist :null-object nil :false-object :json-false)
(json-parse-error
(ement-message "`json-parse-buffer' signaled `json-parse-error'; falling back to `json-read'... (%S)"
(error-message-string err))
(goto-char (point-min))
(json-read))))
'json-read))
;;;;; Emacs 28 color features.
;; Copied from Emacs 28. See <https://github.com/alphapapa/ement.el/issues/99>.
;; TODO(future): Remove these workarounds when dropping support for Emacs <28.
(eval-and-compile
(unless (boundp 'color-luminance-dark-limit)
(defconst ement--color-luminance-dark-limit 0.325
"The relative luminance below which a color is considered \"dark.\"
A \"dark\" color in this sense provides better contrast with
white than with black; see `color-dark-p'. This value was
determined experimentally.")))
(defalias 'ement--color-dark-p
(if (fboundp 'color-dark-p)
'color-dark-p
(with-suppressed-warnings ((free-vars ement--color-luminance-dark-limit))
(lambda (rgb)
"Whether RGB is more readable against white than black.
RGB is a 3-element list (R G B), each component in the range [0,1].
This predicate can be used both for determining a suitable (black or white)
contrast colour with RGB as background and as foreground."
(unless (<= 0 (apply #'min rgb) (apply #'max rgb) 1)
(error "RGB components %S not in [0,1]" rgb))
;; Compute the relative luminance after gamma-correcting (assuming sRGB),
;; and compare to a cut-off value determined experimentally.
;; See https://en.wikipedia.org/wiki/Relative_luminance for details.
(let* ((sr (nth 0 rgb))
(sg (nth 1 rgb))
(sb (nth 2 rgb))
;; Gamma-correct the RGB components to linear values.
;; Use the power 2.2 as an approximation to sRGB gamma;
;; it should be good enough for the purpose of this function.
(r (expt sr 2.2))
(g (expt sg 2.2))
(b (expt sb 2.2))
(y (+ (* r 0.2126) (* g 0.7152) (* b 0.0722))))
(< y ement--color-luminance-dark-limit))))))
;;;; Functions
;;;;; Commands
(cl-defun ement-create-room
(session &key name alias topic invite direct-p creation-content
(then (lambda (data)
(message "Created new room: %s" (alist-get 'room_id data))))
(visibility 'private))
"Create new room on SESSION.
Then call function THEN with response data. Optional string
arguments are NAME, ALIAS, and TOPIC. INVITE may be a list of
user IDs to invite. If DIRECT-P, set the \"is_direct\" flag in
the request. CREATION-CONTENT may be an alist of extra keys to
include with the request (see Matrix spec)."
;; TODO: Document other arguments.
;; SPEC: 10.1.1.
(declare (indent defun))
(interactive (list (ement-complete-session)
:name (read-string "New room name: ")
:alias (read-string "New room alias (e.g. \"foo\" for \"#foo:matrix.org\"): ")
:topic (read-string "New room topic: ")
:visibility (completing-read "New room visibility: " '(private public))))
(cl-labels ((given-p (var) (and var (not (string-empty-p var)))))
(pcase-let* ((endpoint "createRoom")
(data (ement-aprog1
(ement-alist "visibility" visibility)
(when (given-p alias)
(push (cons "room_alias_name" alias) it))
(when (given-p name)
(push (cons "name" name) it))
(when (given-p topic)
(push (cons "topic" topic) it))
(when invite
(push (cons "invite" invite) it))
(when direct-p
(push (cons "is_direct" t) it))
(when creation-content
(push (cons "creation_content" creation-content) it)))))
(ement-api session endpoint :method 'post :data (json-encode data)
:then then))))
(cl-defun ement-create-space
(session &key name alias topic
(then (lambda (data)
(message "Created new space: %s" (alist-get 'room_id data))))
(visibility 'private))
"Create new space on SESSION.
Then call function THEN with response data. Optional string
arguments are NAME, ALIAS, and TOPIC."
(declare (indent defun))
(interactive (list (ement-complete-session)
:name (read-string "New space name: ")
:alias (read-string "New space alias (e.g. \"foo\" for \"#foo:matrix.org\"): ")
:topic (read-string "New space topic: ")
:visibility (completing-read "New space visibility: " '(private public))))
(ement-create-room session :name name :alias alias :topic topic :visibility visibility
:creation-content (ement-alist "type" "m.space") :then then))
(defun ement-room-leave (room session &optional force-p)
"Leave ROOM on SESSION.
If FORCE-P, leave without prompting. ROOM may be an `ement-room'
struct, or a room ID or alias string."
;; TODO: Rename `room' argument to `room-or-id'.
(interactive
(ement-with-room-and-session
:prompt-form (ement-complete-room :prompt "Leave room: ")
(list ement-room ement-session)))
(cl-etypecase room
(ement-room)
(string (setf room (ement-afirst (or (equal room (ement-room-canonical-alias it))
(equal room (ement-room-id it)))
(ement-session-rooms session)))))
(when (or force-p (yes-or-no-p (format "Leave room %s? " (ement--format-room room))))
(pcase-let* (((cl-struct ement-room id) room)
(endpoint (format "rooms/%s/leave" (url-hexify-string id))))
(ement-api session endpoint :method 'post :data ""
:then (lambda (_data)
(when ement-room-leave-kill-buffer
;; NOTE: This generates a symbol and sets its function value to a lambda
;; which removes the symbol from the hook, removing itself from the hook.
;; TODO: When requiring Emacs 27, use `letrec'.
(let* ((leave-fn-symbol (gensym (format "ement-leave-%s" room)))
(leave-fn (lambda (_session)
(remove-hook 'ement-sync-callback-hook leave-fn-symbol)
;; FIXME: Probably need to unintern the symbol.
(when-let ((buffer (map-elt (ement-room-local room) 'buffer)))
(when (buffer-live-p buffer)
(kill-buffer buffer))))))
(setf (symbol-function leave-fn-symbol) leave-fn)
(add-hook 'ement-sync-callback-hook leave-fn-symbol)))
(ement-message "Left room: %s" (ement--format-room room)))
:else (lambda (plz-error)
(pcase-let* (((cl-struct plz-error response) plz-error)
((cl-struct plz-response status body) response)
((map error) (json-read-from-string body)))
(pcase status
(429 (error "Unable to leave room %s: %s" room error))
(_ (error "Unable to leave room %s: %s %S" room status plz-error)))))))))
(defalias 'ement-leave-room #'ement-room-leave)
(defun ement-forget-room (room session &optional force-p)
"Forget ROOM on SESSION.
If FORCE-P (interactively, with prefix), prompt to leave the room
when necessary, and forget the room without prompting."
(interactive
(ement-with-room-and-session
:prompt-form (ement-complete-room :prompt "Forget room: ")
(list ement-room ement-session current-prefix-arg)))
(pcase-let* (((cl-struct ement-room id display-name status) room)
(endpoint (format "rooms/%s/forget" (url-hexify-string id))))
(pcase status
('join (if (and force-p
(yes-or-no-p (format "Leave and forget room %s? (WARNING: You will not be able to rejoin the room to access its content.) "
(ement--format-room room))))
(progn
;; TODO: Use `letrec'.
(let* ((forget-fn-symbol (gensym (format "ement-forget-%s" room)))
(forget-fn (lambda (_session)
(when (equal 'leave (ement-room-status room))
(remove-hook 'ement-sync-callback-hook forget-fn-symbol)
;; FIXME: Probably need to unintern the symbol.
(ement-forget-room room session 'force)))))
(setf (symbol-function forget-fn-symbol) forget-fn)
(add-hook 'ement-sync-callback-hook forget-fn-symbol))
(ement-leave-room room session 'force))
(user-error "Room %s is joined (must be left before forgetting)"
(ement--format-room room))))
('leave (when (or force-p (yes-or-no-p (format "Forget room \"%s\" (%s)? " display-name id)))
(ement-api session endpoint :method 'post :data ""
:then (lambda (_data)
;; NOTE: The spec does not seem to indicate that the action of forgetting
;; a room is synced to other clients, so it seems that we need to remove
;; the room from the session here.
(setf (ement-session-rooms session)
(cl-remove room (ement-session-rooms session)))
;; TODO: Indicate forgotten in footer in room buffer.
(ement-message "Forgot room: %s." (ement--format-room room)))))))))
(defun ement-ignore-user (user-id session &optional unignore-p)
"Ignore USER-ID on SESSION.
If UNIGNORE-P (interactively, with prefix), un-ignore USER."
(interactive (list (ement-complete-user-id)
(ement-complete-session)
current-prefix-arg))
(pcase-let* (((cl-struct ement-session account-data) session)
;; TODO: Store session account-data events in an alist keyed on type.
((map ('content (map ('ignored_users ignored-users))))
(cl-find "m.ignored_user_list" account-data
:key (lambda (event) (alist-get 'type event)) :test #'equal)))
(if unignore-p
;; Being map keys, the user IDs have been interned by `json-read'.
(setf ignored-users (map-delete ignored-users (intern user-id)))
;; Empty maps are used to list ignored users.
(setf (map-elt ignored-users user-id) nil))
(ement-put-account-data session "m.ignored_user_list" (ement-alist "ignored_users" ignored-users)
:then (lambda (data)
(ement-debug "PUT successful" data)
(message "Ement: User %s %s." user-id (if unignore-p "unignored" "ignored"))))))
(defun ement-invite-user (user-id room session)
"Invite USER-ID to ROOM on SESSION.
Interactively, with prefix, prompt for room and session,
otherwise use current room."
;; SPEC: 10.4.2.1.
(interactive
(ement-with-room-and-session
(list (ement-complete-user-id) ement-room ement-session)))
(pcase-let* ((endpoint (format "rooms/%s/invite"
(url-hexify-string (ement-room-id room))))
(data (ement-alist "user_id" user-id) ))
(ement-api session endpoint :method 'post :data (json-encode data)
;; TODO: Handle error codes.
:then (lambda (_data)
(message "User %s invited to room \"%s\" (%s)" user-id
(ement-room-display-name room)
(ement-room-id room))))))
(defun ement-list-members (room session bufferp)
"Show members of ROOM on SESSION.
Interactively, with prefix, prompt for room and session,
otherwise use current room. If BUFFERP (interactively, with
prefix), or if there are many members, show in a new buffer;
otherwise show in echo area."
(interactive
(ement-with-room-and-session
(list ement-room ement-session current-prefix-arg)))
(pcase-let* (((cl-struct ement-room members (local (map fetched-members-p))) room)
(list-members
(lambda (&optional _)
(cond ((or bufferp (> (hash-table-count members) 51))
;; Show in buffer.
(let* ((buffer (get-buffer-create (format "*Ement members: %s*" (ement-room-display-name room))))
(members (cl-sort (cl-loop for user being the hash-values of members
for id = (ement-user-id user)
for displayname = (ement--user-displayname-in room user)
collect (cons displayname id))
(lambda (a b) (string-collate-lessp a b nil t)) :key #'car))
(displayname-width (cl-loop for member in members
maximizing (string-width (car member))))
(format-string (format "%%-%ss <%%s>" displayname-width)))
(with-current-buffer buffer
(erase-buffer)
(save-excursion
(dolist (member members)
(insert (format format-string (car member) (cdr member)) "\n"))))
(pop-to-buffer buffer)))
(t
;; Show in echo area.
(message "Members of %s (%s): %s" (ement--room-display-name room)
(hash-table-count members)
(string-join (map-apply (lambda (_id user)
(ement--user-displayname-in room user))
members)
", ")))))))
(if fetched-members-p
(funcall list-members)
(ement--get-joined-members room session
:then list-members))
(message "Listing members of %s..." (ement--format-room room))))
(defun ement-send-direct-message (session user-id message)
"Send a direct MESSAGE to USER-ID on SESSION.
Uses the latest existing direct room with the user, or creates a
new one automatically if necessary."
;; SPEC: 13.23.2.
(interactive
(let* ((session (ement-complete-session))
(user-id (ement-complete-user-id))
(message (read-string "Message: ")))
(list session user-id message)))
(if-let* ((seen-user (gethash user-id ement-users))
(existing-direct-room (ement--direct-room-for-user seen-user session)))
(progn
(ement-send-message existing-direct-room session :body message)
(message "Message sent to %s <%s> in room %S <%s>."
(ement--user-displayname-in existing-direct-room seen-user)
user-id
(ement-room-display-name existing-direct-room) (ement-room-id existing-direct-room)))
;; No existing room for user: make new one.
(message "Creating new room for user %s..." user-id)
(ement-create-room session :direct-p t :invite (list user-id)
:then (lambda (data)
(let* ((room-id (alist-get 'room_id data))
(room (or (cl-find room-id (ement-session-rooms session)
:key #'ement-room-id)
;; New room hasn't synced yet: make a temporary struct.
(make-ement-room :id room-id)))
(direct-rooms-account-data-event-content
;; FIXME: Make account-data a map.
(alist-get 'content (cl-find-if (lambda (event)
(equal "m.direct" (alist-get 'type event)))
(ement-session-account-data session)))))
;; Mark new room as direct: add the room to the account-data event, then
;; put the new account data to the server. (See also:
;; <https://github.com/matrix-org/matrix-react-sdk/blob/919aab053e5b3bdb5a150fd90855ad406c19e4ab/src/Rooms.ts#L91>).
(setf (map-elt direct-rooms-account-data-event-content user-id) (vector room-id))
(ement-put-account-data session "m.direct" direct-rooms-account-data-event-content)
;; Send message to new room.
(ement-send-message room session :body message)
(message "Room \"%s\" created for user %s. Sending message..."
room-id user-id))))))
(defun ement-tag-room (tag room session)
"Toggle TAG for ROOM on SESSION."
(interactive
(ement-with-room-and-session
(let* ((prompt (format "Toggle tag (%s): " (ement--format-room ement-room)))
(default-tags
(ement-alist (propertize "Favourite"
'face (when (ement--room-tagged-p "m.favourite" ement-room)
'transient-value))
"m.favourite"
(propertize "Low-priority"
'face (when (ement--room-tagged-p "m.lowpriority" ement-room)
'transient-value))
"m.lowpriority"))
(input (completing-read prompt default-tags))
(tag (alist-get input default-tags (concat "u." input) nil #'string=)))
(list tag ement-room ement-session))))
(pcase-let* (((cl-struct ement-session user) session)
((cl-struct ement-user (id user-id)) user)
((cl-struct ement-room (id room-id)) room)
(endpoint (format "user/%s/rooms/%s/tags/%s"
(url-hexify-string user-id) (url-hexify-string room-id) (url-hexify-string tag)))
(method (if (ement--room-tagged-p tag room) 'delete 'put)))
;; TODO: "order".
;; FIXME: Removing a tag on a left room doesn't seem to work (e.g. to unfavorite a room after leaving it, but not forgetting it).
(ement-api session endpoint :version "v3" :method method :data (pcase method ('put "{}"))
:then (lambda (_)
(ement-message "%s tag %S on %s"
(pcase method
('delete "Removed")
('put "Added"))
tag (ement--format-room room)) ))))
(defun ement-set-display-name (display-name session)
"Set DISPLAY-NAME for user on SESSION.
Sets global displayname."
(interactive
(let* ((session (ement-complete-session))
(display-name (read-string "Set display-name to: " nil nil
(ement-user-displayname (ement-session-user session)))))
(list display-name session)))
(pcase-let* (((cl-struct ement-session user) session)
((cl-struct ement-user (id user-id)) user)
(endpoint (format "profile/%s/displayname" (url-hexify-string user-id))))
(ement-api session endpoint :method 'put :version "v3"
:data (json-encode (ement-alist "displayname" display-name))
:then (lambda (_data)
(message "Ement: Display name set to %S for <%s>" display-name
(ement-user-id (ement-session-user session)))))))
(defun ement-room-set-display-name (display-name room session)
"Set DISPLAY-NAME for user in ROOM on SESSION.
Interactively, with prefix, prompt for room and session,
otherwise use current room. Sets the name only in ROOM, not
globally."
(interactive
(ement-with-room-and-session
(let* ((prompt (format "Set display-name in %S to: "
(ement--format-room ement-room)))
(display-name (read-string prompt nil nil
(ement-user-displayname (ement-session-user ement-session)))))
(list display-name ement-room ement-session))))
;; NOTE: This does not seem to be documented in the spec, so we imitate the
;; "/myroomnick" command in SlashCommands.tsx from matrix-react-sdk.
(pcase-let* (((cl-struct ement-room state) room)
((cl-struct ement-session user) session)
((cl-struct ement-user id) user)
(member-event (cl-find-if (lambda (event)
(and (equal id (ement-event-state-key event))
(equal "m.room.member" (ement-event-type event))
(equal "join" (alist-get 'membership (ement-event-content event)))))
state)))
(cl-assert member-event)
(setf (alist-get 'displayname (ement-event-content member-event)) display-name)
(ement-put-state room "m.room.member" id (ement-event-content member-event) session
:then (lambda (_data)
(message "Ement: Display name set to %S for <%s> in %S" display-name
(ement-user-id (ement-session-user session))
(ement--format-room room))))))
;;;;;; Describe room
(defvar ement-describe-room-mode-map
(let ((map (make-sparse-keymap)))
(define-key map (kbd "q") #'quit-window)
map)
"Keymap for `ement-describe-room-mode' buffers.")
(define-derived-mode ement-describe-room-mode read-only-mode
"Ement-Describe-Room" "Major mode for `ement-describe-room' buffers.")
(defun ement-describe-room (room session)
"Describe ROOM on SESSION.
Interactively, with prefix, prompt for room and session,
otherwise use current room."
(interactive (ement-with-room-and-session (list ement-room ement-session)))
(cl-labels ((heading (string)
(propertize (or string "") 'face 'font-lock-builtin-face))
(id (string)
(propertize (or string "") 'face 'font-lock-constant-face))
(member<
(a b) (string-collate-lessp (car a) (car b) nil t)))
(pcase-let* (((cl-struct ement-room (id room-id) avatar display-name canonical-alias members timeline status topic
(local (map fetched-members-p)))
room)
((cl-struct ement-session user) session)
((cl-struct ement-user (id user-id)) user)
(inhibit-read-only t))
(if (not fetched-members-p)
;; Members not fetched: fetch them and re-call this command.
(ement--get-joined-members room session
:then (lambda (_) (ement-room-describe room session)))
(with-current-buffer (get-buffer-create (format "*Ement room description: %s*" (or display-name canonical-alias room-id)))
(let ((inhibit-read-only t))
(erase-buffer)
;; We avoid looping twice by doing a bit more work here and
;; returning a cons which we destructure.
(pcase-let* ((`(,member-pairs . ,name-width)
(cl-loop for user being the hash-values of members
for formatted = (ement--format-user user room session)
for id = (format "<%s>" (id (ement-user-id user)))
collect (cons formatted id)
into pairs
maximizing (string-width id) into width
finally return (cons (cl-sort pairs #'member<) width)))
;; We put the MXID first, because users may use Unicode characters
;; in their displayname, which `string-width' does not always
;; return perfect results for, and putting it last prevents
;; alignment problems.
(spec (format "%%-%ss %%s" name-width)))
(save-excursion
(insert "\"" (propertize (or display-name canonical-alias room-id) 'face 'font-lock-doc-face) "\"" " is a "
(propertize (if (ement--space-p room)
"space"
"room")
'face 'font-lock-type-face)
" "
(propertize (pcase status
('invite "invited")
('join "joined")
('leave "left")
(_ (symbol-name status)))
'face 'font-lock-comment-face)
" on session <" (id user-id) ">.\n\n"
(heading "Avatar: ") (or avatar "") "\n\n"
(heading "ID: ") "<" (id room-id) ">" "\n"
(heading "Alias: ") "<" (id canonical-alias) ">" "\n\n"
(heading "Topic: ") (propertize (or topic "[none]") 'face 'font-lock-comment-face) "\n\n"
(heading "Retrieved events: ") (number-to-string (length timeline)) "\n"
(heading " spanning: ")
(format-time-string "%Y-%m-%d %H:%M:%S"
(/ (ement-event-origin-server-ts
(car (cl-sort (copy-sequence timeline) #'< :key #'ement-event-origin-server-ts)))
1000))
(heading " to ")
(format-time-string "%Y-%m-%d %H:%M:%S\n\n"
(/ (ement-event-origin-server-ts
(car (cl-sort (copy-sequence timeline) #'> :key #'ement-event-origin-server-ts)))
1000))
(heading "Members") " (" (number-to-string (hash-table-count members)) "):\n")
(pcase-dolist (`(,formatted . ,id) member-pairs)
(insert " " (format spec id formatted) "\n")))))
(unless (eq major-mode 'ement-describe-room-mode)
;; Without this check, activating the mode again causes a "Cyclic keymap
;; inheritance" error.
(ement-describe-room-mode))
(pop-to-buffer (current-buffer)))))))
(defalias 'ement-room-describe #'ement-describe-room)
;;;;;; Push rules
;; NOTE: Although v1.4 of the spec is available and describes setting the push rules using
;; the "v3" API endpoint, the Element client continues to use the "r0" endpoint, which is
;; slightly different. This implementation will follow Element's initially, because the
;; spec is not simple, and imitating Element's requests will make it easier.
(defun ement-room-notification-state (room session)
"Return notification state for ROOM on SESSION.
Returns one of nil (meaning default rules are used), `all-loud',
`all', `mentions-and-keywords', or `none'."
;; Following the implementation of getRoomNotifsState() in RoomNotifs.ts in matrix-react-sdk.
;; TODO: Guest support (in which case the state should be `all').
;; TODO: Store account data as a hash table of event types.
(let ((push-rules (cl-find-if (lambda (alist)
(equal "m.push_rules" (alist-get 'type alist)))
(ement-session-account-data session))))
(cl-labels ((override-mute-rule-for-room-p (room)
;; Following findOverrideMuteRule() in RoomNotifs.ts.
(when-let ((overrides (map-nested-elt push-rules '(content global override))))
(cl-loop for rule in overrides
when (and (alist-get 'enabled rule)
(rule-for-room-p rule room))
return rule)))
(rule-for-room-p (rule room)
;; Following isRuleForRoom() in RoomNotifs.ts.
(and (/= 1 (length (alist-get 'conditions rule)))
(pcase-let* ((condition (elt (alist-get 'conditions rule) 0))
((map kind key pattern) condition))
(and (equal "event_match" kind)
(equal "room_id" key)
(equal (ement-room-id room) pattern)))))
(mute-rule-p (rule)
(when-let ((actions (alist-get 'actions rule)))
(seq-contains-p actions "dont_notify")))
;; NOTE: Although v1.7 of the spec says that "dont_notify" is
;; obsolete, the latest revision of matrix-react-sdk (released last week
;; as v3.77.1) still works as modeled here.
(tweak-rule-p (type rule)
(when-let ((actions (alist-get 'actions rule)))
(and (seq-contains-p actions "notify")
(seq-contains-p actions `(set_tweak . ,type) 'seq-contains-p)))))
;; If none of these match, nil is returned, meaning that the default rule is used
;; for the room.
(if (override-mute-rule-for-room-p room)
'none
(when-let ((room-rule (cl-find-if (lambda (rule)
(equal (ement-room-id room) (alist-get 'rule_id rule)))
(map-nested-elt push-rules '(content global room)))))
(cond ((not (alist-get 'enabled room-rule))
;; NOTE: According to comment in getRoomNotifsState(), this assumes that
;; the default is to notify for all messages, which "will be 'wrong' for
;; one to one rooms because they will notify loudly for all messages."
'all)
((mute-rule-p room-rule)
;; According to comment, a room-level mute still allows mentions to
;; notify. NOTE: See note above.
'mentions-and-keywords)
((tweak-rule-p "sound" room-rule) 'all-loud)))))))
(defun ement-room-set-notification-state (state room session)
"Set notification STATE for ROOM on SESSION.
Interactively, with prefix, prompt for room and session,
otherwise use current room. STATE may be nil to set the rules to
default, `all', `mentions-and-keywords', or `none'."
;; This merely attempts to reproduce the behavior of Element's simple notification
;; options. It does not attempt to offer all of the features defined in the spec. And,
;; yes, it is rather awkward, having to sometimes* make multiple requests of different
;; "kinds" to set the rules for a single room, but that is how the API works.
;;
;; * It appears that Element only makes multiple requests of different kinds when
;; strictly necessary, but coding that logic now would seem likely to be a waste of
;; time, given that Element doesn't even use the latest version of the spec yet. So
;; we'll just do the "dumb" thing and always send requests of both "override" and
;; "room" kinds, which appears to Just Work™.
;;
;; TODO: Match rules to these user-friendly notification states for presentation. See
;; <https://github.com/matrix-org/matrix-react-sdk/blob/8c67984f50f985aa481df24778078030efa39001/src/RoomNotifs.ts>.
;; TODO: Support `all-loud' ("all_messages_loud").
(interactive
(ement-with-room-and-session
(let* ((prompt (format "Set notification rules for %s: " (ement--format-room ement-room)))
(available-states (ement-alist "Default" nil
"All messages" 'all
"Mentions and keywords" 'mentions-and-keywords
"None" 'none))
(selected-rule (completing-read prompt (mapcar #'car available-states) nil t))
(state (alist-get selected-rule available-states nil nil #'equal)))
(list state ement-room ement-session))))
(cl-labels ((set-rule (kind rule queue message-fn)
(pcase-let* (((cl-struct ement-room (id room-id)) room)
(rule-id (url-hexify-string room-id))
(endpoint (format "pushrules/global/%s/%s" kind rule-id))
(method (if rule 'put 'delete))
(then (if rule
;; Setting rules requires PUTting the rules, then making a second
;; request to enable them.
(lambda (_data)
(ement-api session (concat endpoint "/enabled") :queue queue :version "r0"
:method 'put :data (json-encode (ement-alist 'enabled t))
:then message-fn))
message-fn)))
(ement-api session endpoint :queue queue :method method :version "r0"
:data (json-encode rule)
:then then
:else (lambda (plz-error)
(pcase-let* (((cl-struct plz-error response) plz-error)
((cl-struct plz-response status) response))
(pcase status
(404 (pcase rule
(`nil
;; Room already had no rules, so none being found is not an
;; error.
nil)
(_ ;; Unexpected error: re-signal.
(ement-api-error plz-error))))
(_ ;; Unexpected error: re-signal.
(ement-api-error plz-error)))))))))
(pcase-let* ((available-states
(ement-alist
nil (ement-alist
"override" nil
"room" nil)
'all (ement-alist
"override" nil
"room" (ement-alist
'actions (vector "notify" (ement-alist
'set_tweak "sound"
'value "default"))))
'mentions-and-keywords (ement-alist
"override" nil
"room" (ement-alist
'actions (vector "dont_notify")))
'none (ement-alist
"override" (ement-alist
'actions (vector "dont_notify")
'conditions (vector (ement-alist
'kind "event_match"
'key "room_id"
'pattern (ement-room-id room))))
"room" nil)))
(kinds-and-rules (alist-get state available-states nil nil #'equal)))
(cl-loop with queue = (make-plz-queue :limit 1)
with total = (1- (length kinds-and-rules))
for count from 0
for message-fn = (if (equal count total)
(lambda (_data)
(message "Set notification rules for room: %s" (ement--format-room room)))
#'ignore)
for (kind . state) in kinds-and-rules
do (set-rule kind state queue message-fn)))))
;;;;; Public functions
;; These functions could reasonably be called by code in other packages.
(cl-defun ement-put-state
(room type key data session
&key (then (lambda (response-data)
(ement-debug "State data put on room" response-data data room session))))
"Put state event of TYPE with KEY and DATA on ROOM on SESSION.
DATA should be an alist, which will become the JSON request
body."
(declare (indent defun))
(pcase-let* ((endpoint (format "rooms/%s/state/%s/%s"
(url-hexify-string (ement-room-id room))
type key)))
(ement-api session endpoint :method 'put :data (json-encode data)
;; TODO: Handle error codes.
:then then)))
(defun ement-message (format-string &rest args)
"Call `message' on FORMAT-STRING prefixed with \"Ement: \"."
;; TODO: Use this function everywhere we use `message'.
(apply #'message (concat "Ement: " format-string) args))
(cl-defun ement-upload (session &key data filename then else
(content-type "application/octet-stream"))
"Upload DATA with FILENAME to content repository on SESSION.
THEN and ELSE are passed to `ement-api', which see."
(declare (indent defun))
(ement-api session "upload" :method 'post :endpoint-category "media"
;; NOTE: Element currently uses "r0" not "v3", so so do we.
:params (when filename
(list (list "filename" filename)))
:content-type content-type :data data :data-type 'binary
:then then :else else))
(cl-defun ement-complete-session (&key (prompt "Session: "))
"Return an Ement session selected with completion."
(pcase (length ement-sessions)
(0 (user-error "No active sessions. Call `ement-connect' to log in"))
(1 (cdar ement-sessions))
(_ (let* ((ids (mapcar #'car ement-sessions))
(selected-id (completing-read prompt ids nil t)))
(alist-get selected-id ement-sessions nil nil #'equal)))))
(declare-function ewoc-locate "ewoc")
(defun ement-complete-user-id ()
"Return a user-id selected with completion.
Selects from seen users on all sessions. If point is on an
event, suggests the event's sender as initial input. Allows
unseen user IDs to be input as well."
(cl-labels ((format-user (user)
;; FIXME: Per-room displaynames are now stored in room structs
;; rather than user structs, so to be complete, this needs to
;; iterate over all known rooms, looking for the user's
;; displayname in that room.
(format "%s <%s>"
(ement-user-displayname user)
(ement-user-id user))))
(let* ((display-to-id
(cl-loop for key being the hash-keys of ement-users
using (hash-values value)
collect (cons (format-user value) key)))
(user-at-point (when (equal major-mode 'ement-room-mode)
(when-let ((node (ewoc-locate ement-ewoc)))
(when (ement-event-p (ewoc-data node))
(format-user (ement-event-sender (ewoc-data node)))))))
(selected-user (completing-read "User: " (mapcar #'car display-to-id)
nil nil user-at-point)))
(or (alist-get selected-user display-to-id nil nil #'equal)
selected-user))))
(cl-defun ement-put-account-data
(session type data &key room
(then (lambda (received-data)
;; Handle echoed-back account data event (the spec does not explain this,
;; but see <https://github.com/matrix-org/matrix-react-sdk/blob/675b4271e9c6e33be354a93fcd7807253bd27fcd/src/settings/handlers/AccountSettingsHandler.ts#L150>).
;; FIXME: Make session account-data a map instead of a list of events.
(if room
(push received-data (ement-room-account-data room))
(push received-data (ement-session-account-data session)))
;; NOTE: Commenting out this ement-debug form because a bug in Emacs
;; causes this long string to be interpreted as the function's
;; docstring and cause a too-long-docstring warning.
;; (ement-debug "Account data put and received back on session %s: PUT(json-encoded):%S RECEIVED:%S"
;; (ement-user-id (ement-session-user session)) (json-encode data) received-data)
)))
"Put account data of TYPE with DATA on SESSION.
If ROOM, put it on that room's account data. Also handle the
echoed-back event."
(declare (indent defun))
(pcase-let* (((cl-struct ement-session (user (cl-struct ement-user (id user-id)))) session)
(room-part (if room (format "/rooms/%s" (ement-room-id room)) ""))
(endpoint (format "user/%s%s/account_data/%s" (url-hexify-string user-id) room-part type)))
(ement-api session endpoint :method 'put :data (json-encode data)
:then then)))
(defun ement-redact (event room session &optional reason)
"Redact EVENT in ROOM on SESSION, optionally for REASON."
(pcase-let* (((cl-struct ement-event (id event-id)) event)
((cl-struct ement-room (id room-id)) room)
(endpoint (format "rooms/%s/redact/%s/%s"
room-id event-id (ement--update-transaction-id session)))
(content (ement-alist "reason" reason)))
(ement-api session endpoint :method 'put :data (json-encode content)
:then (lambda (_data)
(message "Event %s redacted." event-id)))))
;;;;; Inline functions
(defsubst ement--user-color (user)
"Return USER's color, setting it if necessary.
USER is an `ement-user' struct."
(or (ement-user-color user)
(setf (ement-user-color user)
(ement--prism-color (ement-user-id user)))))
;;;;; Private functions
;; These functions aren't expected to be called by code in other packages (but if that
;; were necessary, they could be renamed accordingly).
;; (defun ement--room-routing (room)
;; "Return a list of servers to route to ROOM through."
;; ;; See <https://spec.matrix.org/v1.2/appendices/#routing>.
;; ;; FIXME: Ensure highest power level user is at least level 50.
;; ;; FIXME: Ignore servers blocked due to server ACLs.
;; ;; FIXME: Ignore servers which are IP addresses.
;; (cl-labels ((most-powerful-user-in
;; (room))
;; (servers-by-population-in
;; (room))
;; (server-of (user)))
;; (let (first-server-by-power-level)
;; (delete-dups
;; (remq nil
;; (list
;; ;; 1.
;; (or (when-let ((user (most-powerful-user-in room)))
;; (setf first-server-by-power-level t)
;; (server-of user))
;; (car (servers-by-population-in room)))
;; ;; 2.
;; (if first-server-by-power-level
;; (car (servers-by-population-in room))
;; (cl-second (servers-by-population-in room)))
;; ;; 3.
;; (cl-third (servers-by-population-in room))))))))
(defun ement--space-p (room)
"Return non-nil if ROOM is a space."
(equal "m.space" (ement-room-type room)))
(defun ement--room-in-space-p (room space)
"Return non-nil if ROOM is in SPACE on SESSION."
;; We could use `ement---room-spaces', but since that returns rooms by looking them up
;; by ID in the session's rooms list, this is more efficient.
(pcase-let* (((cl-struct ement-room (id parent-id) (local (map children))) space)
((cl-struct ement-room (id child-id) (local (map parents))) room))
(or (member parent-id parents)
(member child-id children))))
(defun ement--room-spaces (room session)
"Return list of ROOM's parent spaces on SESSION."
;; NOTE: This only looks in the room's parents list; it doesn't look in every space's children
;; list. This should be good enough, assuming we add to the lists correctly elsewhere.
(pcase-let* (((cl-struct ement-session rooms) session)
((cl-struct ement-room (local (map parents))) room))
(cl-remove-if-not (lambda (session-room-id)
(member session-room-id parents))
rooms :key #'ement-room-id)))
(cl-defun ement--prism-color (string &key (contrast-with (face-background 'default nil 'default)))
"Return a computed color for STRING.
The color is adjusted to have sufficient contrast with the color
CONTRAST-WITH (by default, the default face's background). The
computed color is useful for user messages, generated room
avatars, etc."
;; TODO: Use this instead of `ement-room--user-color'. (Same algorithm ,just takes a
;; string as argument.)
;; TODO: Try using HSV somehow so we could avoid having so many strings return a
;; nearly-black color.
(cl-labels ((relative-luminance (rgb)
;; Copy of `modus-themes-wcag-formula', an elegant
;; implementation by Protesilaos Stavrou. Also see
;; <https://en.wikipedia.org/wiki/Relative_luminance> and
;; <https://www.w3.org/TR/WCAG20/#relativeluminancedef>.
(cl-loop for k in '(0.2126 0.7152 0.0722)
for x in rgb
sum (* k (if (<= x 0.03928)
(/ x 12.92)
(expt (/ (+ x 0.055) 1.055) 2.4)))))
(contrast-ratio (a b)
;; Copy of `modus-themes-contrast'; see above.
(let ((ct (/ (+ (relative-luminance a) 0.05)
(+ (relative-luminance b) 0.05))))
(max ct (/ ct))))
(increase-contrast (color against target toward)
(let ((gradient (cdr (color-gradient color toward 20)))
new-color)
(cl-loop do (setf new-color (pop gradient))
while new-color
until (>= (contrast-ratio new-color against) target)
;; Avoid infinite loop in case of weirdness
;; by returning color as a fallback.
finally return (or new-color color)))))
(let* ((id string)
(id-hash (float (+ (abs (sxhash id)) ement-room-prism-color-adjustment)))
;; TODO: Wrap-around the value to get the color I want.
(ratio (/ id-hash (float most-positive-fixnum)))
(color-num (round (* (* 255 255 255) ratio)))
(color-rgb (list (/ (float (logand color-num 255)) 255)
(/ (float (ash (logand color-num 65280) -8)) 255)
(/ (float (ash (logand color-num 16711680) -16)) 255)))
(contrast-with-rgb (color-name-to-rgb contrast-with)))
(when (< (contrast-ratio color-rgb contrast-with-rgb) ement-room-prism-minimum-contrast)
(setf color-rgb (increase-contrast color-rgb contrast-with-rgb ement-room-prism-minimum-contrast
(color-name-to-rgb
;; Ideally we would use the foreground color,
;; but in some themes, like Solarized Dark,
;; the foreground color's contrast is too low
;; to be effective as the value to increase
;; contrast against, so we use white or black.
(pcase contrast-with
((or `nil "unspecified-bg")
;; The `contrast-with' color (i.e. the
;; default background color) is nil. This
;; probably means that we're displaying on
;; a TTY.
(if (fboundp 'frame--current-backround-mode)
;; This function can tell us whether
;; the background color is dark or
;; light, but it was added in Emacs
;; 28.1.
(pcase (frame--current-backround-mode (selected-frame))
('dark "white")
('light "black"))
;; Pre-28.1: Since faces' colors may be
;; "unspecified" on TTY frames, in which
;; case we have nothing to compare with, we
;; assume that the background color of such
;; a frame is black and increase contrast
;; toward white.
"white"))
(_
;; The `contrast-with` color is usable: test it.
(if (ement--color-dark-p (color-name-to-rgb contrast-with))
"white" "black")))))))
(apply #'color-rgb-to-hex (append color-rgb (list 2))))))
(cl-defun ement--format-user (user &optional (room ement-room) (session ement-session))
"Format `ement-user' USER for ROOM on SESSION.
ROOM defaults to the value of `ement-room'."
(let ((face (cond ((equal (ement-user-id (ement-session-user session))
(ement-user-id user))
'ement-room-self)
(ement-room-prism
`(:inherit ement-room-user :foreground ,(or (ement-user-color user)
(setf (ement-user-color user)
(ement--prism-color user)))))