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
|
;;;; Common utilities to help in building bots
(in-package :granolin)
;;; Logging Bot
(defclass message-log ()
((output
:accessor output
:initarg :output
:initform (error "Message Log requires an output stream")
:type stream
:documentation "An output stream to which messages are logged."
)))
(defun print-assoc (alist &optional (stream t))
(loop :for (k . v) :in alist
:do (format stream "~a: ~a~%" k v)))
(defmethod handle-event :after ((log message-log) (event timeline-event) &optional room)
(print "Joined Room Message/Timeline Event" (output log))
(let ((fields `(("room" . ,room)
("sender" . ,(sender event))
("event type" . ,(event-type event))
("message type" . ,(msg-type event))
("messge body" . ,(msg-body event))
("content" . ,(event-content event)))))
(print-assoc fields (output log))
(terpri (output log))))
(defmethod handle-event :after ((log message-log) (event room-state-event) &optional room)
(print "Joined Room State Event" (output log))
(let ((fields `(("room" . ,room)
("sender" . ,(sender event))
("event type" . ,(event-type event))
("state key" . ,(state-key event))
("content" . ,(event-content event)))))
(print-assoc fields (output log))
(terpri (output log))))
(defmethod handle-event :after ((log message-log) (event invitation-event) &optional room)
(print "Invitation Event" (output log))
(let ((fields `(("room" . ,room)
("sender" . ,(sender event))
("event type" . ,(event-type event))
("state key" . ,(state-key event))
("content" . ,(event-content event)))))
(print-assoc fields (output log))
(terpri (output log))))
;;; A Room and User Directory Bot
(defclass server-room ()
((id :accessor room-id :initarg :id :initform (error "Must have a room-id"))
(name :accessor room-name :initarg :name :initform "")
(aliases :accessor room-aliases :initarg :aliases :initform nil)
(members :accessor room-members :initarg :members :initform nil)
(direct-p :accessor direct-p :initarg :direct-p :initform nil)))
(defclass server-directory ()
((directory-table
:reader directory-table
:initform (make-hash-table :test 'equal)
:documentation "A table mapping room IDs to room struct instances.")))
(defun get-room (client room-id)
"Get the SERVER-ROOM struct keyed by ROOM-ID, or return NIL."
(gethash room-id (directory-table client)))
(defun update-room-name (client room-id name)
(let ((room (get-room client room-id)))
(if room
(setf (room-name room) name)
(setf room (make-instance 'server-room :id room-id :name name)))
(setf (gethash room-id (directory-table client)) room)))
(defun update-room-member (client room-id member)
(let ((room (get-room client room-id)))
(if room
(pushnew member (room-members room) :test #'equal)
(setf room (make-instance 'server-room :id room-id :members (list member))))
(setf (gethash room-id (directory-table client)) room)))
;; TODO
(defun update-room-aliases (client room-id member)
(declare (ignore client room-id member)))
(defmethod handle-event :after ((client server-directory)
(event room-state-event)
&optional room-id)
(cond
((string= "m.room.name" (event-type event))
(update-room-name client room-id (room-name event)))
((string= "m.room.member" (event-type event))
(update-room-member client room-id (sender event)))
((string= "m.room.aliases" (event-type event))
(update-room-aliases client room-id (room-aliases event)))))
(defmethod handle-event :after ((client server-directory)
(event account-data-event)
&optional room-id)
(declare (ignore room-id))
(when (equal "m.direct" (event-type event))
(loop :for (user room-ids . more) :on (event-content event) :by #'cddr :do
(dolist (room-id room-ids)
(mark-as-direct client room-id)))))
(defun mark-as-direct (client room-id)
(setf (direct-p (get-room client room-id)) t))
(defun name-of-room (client room-id)
"Looks up the name of a room with ROOM-ID. Returns a string of NIL"
(let ((room (get-room client room-id)))
(when room (room-name room))))
(defun find-rooms-named (client name &key like full)
"Looks up the room ID of rooms with the name NAME. If LIKE is T, then any room
whose name contains the NAME as a substring is returned. If FULL is T, then
the SERVER-ROOM structs themselves are returned."
(with-slots (directory-table) client
(loop :for room :being :the :hash-values :of directory-table
:when (or (string-equal name (room-name room))
(and like (search name (room-name room) :test #'string-equal)))
:collect (if full room (room-id room)))))
(defun client-contacts (client)
"Returns a list of all users this client knows about."
(let (contacts)
(loop :for room :being :the :hash-values :of (directory-table client) :do
(dolist (user (room-members room))
(pushnew user contacts :test #'equal)))
contacts))
(defun room-member-p (room name &key like)
(some (lambda (memb) (or (equal name memb)
(and like (search name memb :test #'string-equal))))
(members room)))
;; TODO might be too nebulous. Could be split up into two functions.
(defun find-contact (client name &key like get-direct-room)
"Finds a specific matrix or room ID by user name.
If LIKE is NIL, returns a string equal to NAME if this client has a contact
with that NAME, or NIL otherwise.
If LIKE is not NIL, returns the first matrix ID found that contains NAME as a
substring, or NIL if no such matrix ID is found.
If GET-DIRECT-ROOM is not NIL, behave as above, except return a room address
instead. The returned address is usable for direct chats with the contact."
(if get-direct-room
;; return a room-id if the room is marked as direct and has name as a member
(with-hash-table-iterator (next-room (directory-table client))
(loop
(multiple-value-bind (theres-more room-id room) (next-room)
(unless theres-more (return nil))
(when (and (direct-p room)
(room-member-p room name :like like))
(return room-id)))))
;; return a user-id
(find-if (lambda (contact)
(or (equal name contact)
(and like (search name contact :test #'string-equal))))
(client-contacts client))))
(defun ensure-direct-room (client name &key like)
(let-if (room (find-contact client name :like like :get-direct-room t))
room
(create-direct-message-room client name :like like)))
;;; Basic Joiner Bot
(defclass auto-joiner () ())
(defmethod handle-event :after ((client auto-joiner) (event invitation-event) &optional room-id)
(when (equal "invite"
(getf (event-content event) :|join_rule|))
(join-room client room-id)))
|
