event.lisp 1 ;;;; $Id: event.lisp 243 2013-07-01 20:16:35Z jdanjou $
2 ;;;; $URL: file:///project/cl-irc/svn/tags/0.9.2/event.lisp $
3
4 ;;;; See LICENSE for licensing information.
5
6 (in-package :irc)
7
8 (defgeneric irc-message-event (connection message)
9 (:documentation "Upon receipt of an IRC message from the
10 connection's stream, irc-message-event will be called with the
11 message."))
12
13 (defmethod irc-message-event (connection (message irc-message))
14 (declare (ignore connection))
15 (unless (apply-to-hooks message)
16 (client-log (connection message) message "UNHANDLED-EVENT:")))
17
18 (defgeneric dcc-message-event (connection message)
19 (:documentation "Upon receipt of an IRC message from the
20 connection's stream, irc-message-event will be called with the
21 message."))
22
23 (defmethod dcc-message-event (connection (message dcc-message))
24 (declare (ignore connection))
25 (unless (apply-to-hooks message)
26 (client-log (connection message) message "UNHANDLED-EVENT:")))
27
28
29 (defgeneric default-hook (message)
30 (:documentation "Minimum action to be executed upon reception
31 of the IRC message to keep the connection, channel and user
32 objects in sync."))
33
34 (defmacro generate-maskmode-hooks (listmsg-class endmsg-class
35 tmp-symbol mode-symbol)
36 `(progn
37 (defmethod default-hook ((message ,listmsg-class))
38 (destructuring-bind
39 (target channel-name mask &optional set-by time-set)
40 (arguments message)
41 (declare (ignore target set-by time-set))
42 ;; note: the structure currently does not allow for logging
43 ;; set-by and time-set: the MODE message handling currently
44 ;; does not allow that.
45 (let ((channel (find-channel (connection message) channel-name)))
46 (when channel
47 (unless (has-mode-p channel ',tmp-symbol)
48 ;; start with a new list, replacing the old value later
49 (add-mode channel ',tmp-symbol
50 (make-instance 'list-value-mode
51 :value-type :non-user)))
52 ;; use package-local symbol to prevent conflicts
53 (set-mode channel ',tmp-symbol mask)))))
54
55 (defmethod default-hook ((message ,endmsg-class))
56 (let ((channel (find-channel (connection message)
57 (car (arguments message)))))
58 (when channel
59 (let ((mode (has-mode-p channel ',tmp-symbol)))
60 (when mode
61 ;; replace list
62 (add-mode channel ',mode-symbol mode)
63 (remove-mode channel ',tmp-symbol))))))))
64
65 (generate-maskmode-hooks irc-rpl_banlist-message
66 irc-rpl_endofbanlist-message
67 banlist-in-progress :ban)
68 (generate-maskmode-hooks irc-rpl_exceptlist-message
69 irc-rpl_endofexceptlist-message
70 exceptlist-in-progress :except)
71 (generate-maskmode-hooks irc-rpl_invitelist-message
72 irc-rpl_endofinvitelist-message
73 invitelist-in-progress :invite)
74
75 (defmethod default-hook ((message irc-rpl_isupport-message))
76 (destructuring-bind
77 (target &rest capabilities)
78 ;; the last argument contains only an explanitory text
79 (butlast (arguments message))
80 (declare (ignore target))
81 (let* ((connection (connection message))
82 (current-case-mapping (case-map-name connection)))
83 (flet ((split-arg (x)
84 (let ((eq-pos (position #\= x)))
85 (if eq-pos
86 (list (substring x 0 eq-pos)
87 (substring x (1+ eq-pos)))
88 (list x))))
89 (decode-arg (text)
90 ;; decode \xHH into (char-code HH)
91 ;; btw: how should that work with multibyte utf8?
92 (format nil "~{~A~}"
93 (do* ((start 0 (+ 4 pos))
94 (pos (search "\\x" text)
95 (search "\\x" text :start2 (1+ pos)))
96 (points))
97 ((null pos)
98 (reverse (push (substring text start) points)))
99 (push (substring text start pos) points)
100 (push (code-char (parse-integer text
101 :start (+ 2 pos)
102 :end (+ 4 pos)
103 :junk-allowed nil
104 :radix 16))
105 points))))
106 (negate-param (param)
107 (if (eq #\- (char (first param) 0))
108 (assoc (substring (first param) 1)
109 *default-isupport-values*
110 :test #'string=)
111 param)))
112
113 (setf (server-capabilities connection)
114 (reduce #'(lambda (x y)
115 (adjoin y x :key #'first :test #'string=))
116 (append
117 (remove nil (mapcar #'negate-param
118 (mapcar #'(lambda (x)
119 (mapcar #'decode-arg x))
120 (mapcar #'split-arg
121 capabilities))))
122 (server-capabilities connection))
123 :initial-value '()))
124 (setf (channel-mode-descriptions connection)
125 (chanmode-descs-from-isupport (server-capabilities connection))
126 (nick-prefixes connection)
127 (nick-prefixes-from-isupport (server-capabilities connection)))
128 (when (not (equal current-case-mapping
129 (case-map-name connection)))
130 ;; we need to re-normalize nicks and channel names
131 (re-apply-case-mapping connection))))))
132
133 (defmethod default-hook ((message irc-rpl_whoisuser-message))
134 (destructuring-bind
135 (target nick username hostname star realname)
136 (arguments message)
137 (declare (ignore target star))
138 (let ((user (find-user (connection message) nick)))
139 (when user
140 (setf (realname user) realname
141 (username user) username
142 (hostname user) hostname)))))
143
144 (defmethod default-hook ((message irc-rpl_welcome-message))
145 (with-slots
146 (connection host user arguments)
147 message
148 (destructuring-bind
149 (nickname welcome-message)
150 arguments
151 (setf (user connection)
152 (make-user connection
153 :nickname nickname
154 :hostname host
155 :username user)))))
156
157 (defmethod default-hook ((message irc-rpl_list-message))
158 (destructuring-bind
159 (channel count topic)
160 (arguments message)
161 (let ((connection (connection message))
162 (user-count (parse-integer count)))
163 (add-channel connection (or (find-channel connection channel)
164 (make-channel connection
165 :name channel
166 :topic topic
167 :user-count user-count))))))
168
169 (defmethod default-hook ((message irc-rpl_topic-message))
170 (destructuring-bind
171 (target channel &optional topic)
172 (arguments message)
173 (declare (ignore target))
174 (setf (topic (find-channel (connection message) channel)) topic)))
175
176 (defmethod default-hook ((message irc-rpl_namreply-message))
177 (let* ((connection (connection message)))
178 (destructuring-bind
179 (nick chan-visibility channel names)
180 (arguments message)
181 (declare (ignore nick))
182 (let ((channel (find-channel connection channel)))
183 (setf (visibility channel)
184 (or (second (assoc chan-visibility
185 '(("=" :public) ("*" :private) ("@" :secret))
186 :test #'string=))
187 :unknown))
188 (unless (has-mode-p channel 'namreply-in-progress)
189 (add-mode channel 'namreply-in-progress
190 (make-instance 'list-value-mode :value-type :user)))
191 (dolist (nickname (tokenize-string names))
192 (let ((user (find-or-make-user connection
193 (canonicalize-nickname connection
194 nickname))))
195 (unless (equal user (user connection))
196 (add-user connection user)
197 (add-user channel user))
198 (set-mode channel 'namreply-in-progress user)
199 (let* ((mode-char (getf (nick-prefixes connection)
200 (elt nickname 0)))
201 (mode-name (when mode-char
202 (mode-name-from-char connection
203 channel mode-char))))
204 (when mode-name
205 (if (has-mode-p channel mode-name)
206 (set-mode channel mode-name user)
207 (set-mode-value (add-mode channel mode-name
208 (make-mode connection
209 channel mode-name))
210 user))))))))))
211
212 (defmethod default-hook ((message irc-rpl_endofnames-message))
213 (let* ((channel (find-channel (connection message)
214 (second (arguments message))))
215 (mode (get-mode channel 'namreply-in-progress))
216 (channel-users))
217 (remove-mode channel 'namreply-in-progress)
218 (maphash #'(lambda (nick user-obj)
219 (declare (ignore nick))
220 (pushnew user-obj channel-users)) (users channel))
221 (dolist (user (remove-if #'(lambda (x)
222 (member x mode)) channel-users))
223 (remove-user channel user))))
224
225 (defmethod default-hook ((message irc-ping-message))
226 (apply #'pong (connection message) (arguments message)))
227
228 (defmethod default-hook ((message irc-join-message))
229 (with-slots
230 (connection source host user arguments)
231 message
232 (destructuring-bind
233 (channel)
234 arguments
235 (let ((user (find-or-make-user connection source
236 :hostname host
237 :username user))
238 (channel (or (find-channel connection channel)
239 (make-channel connection :name channel))))
240 (when (self-message-p message)
241 (add-channel connection channel))
242 (add-user connection user)
243 (add-user channel user)))))
244
245 (defmethod default-hook ((message irc-topic-message))
246 (with-slots
247 (connection arguments)
248 message
249 (destructuring-bind
250 (channel &optional topic)
251 arguments
252 (setf (topic (find-channel connection channel)) topic))))
253
254 (defmethod default-hook ((message irc-part-message))
255 (with-slots
256 (connection arguments source)
257 message
258 (destructuring-bind
259 (channel &optional text)
260 arguments
261 (declare (ignore text))
262 (let ((channel (find-channel connection channel))
263 (user (find-user connection source)))
264 (when (and user channel)
265 (if (self-message-p message)
266 (remove-channel user channel)
267 (remove-user channel user)))))))
268
269 (defmethod default-hook ((message irc-quit-message))
270 (let* ((connection (connection message))
271 (user (find-user connection (source message))))
272 (unless (null user)
273 (remove-user-everywhere connection user))))
274
275 (defmethod default-hook ((message irc-rpl_channelmodeis-message))
276 (with-slots
277 (connection arguments)
278 message
279 (destructuring-bind
280 (target channel &rest mode-arguments)
281 arguments
282 (let ((channel (find-channel connection channel)))
283 (when channel
284 (apply-mode-changes connection channel
285 mode-arguments (user connection)))))))
286
287 (defmethod default-hook ((message irc-mode-message))
288 (destructuring-bind
289 (target &rest arguments)
290 (arguments message)
291 (let* ((connection (connection message))
292 (target (or (find-channel connection target)
293 (find-user connection target))))
294 (when target
295 (apply-mode-changes connection target arguments (user connection))))))
296
297 (defmethod default-hook ((message irc-nick-message))
298 (with-slots
299 (connection source host user arguments)
300 message
301 (destructuring-bind
302 (new-nick)
303 arguments
304 (let* ((user (find-or-make-user connection source
305 :hostname host
306 :username user)))
307 (change-nickname connection user new-nick)))))
308
309 (defmethod default-hook ((message irc-kick-message))
310 (with-slots
311 (connection arguments)
312 message
313 (destructuring-bind
314 (channel nick &optional reason)
315 arguments
316 (declare (ignore reason))
317 (let* ((channel (find-channel connection channel))
318 (user (find-user connection nick)))
319 (when (and user channel)
320 (if (user-eq-me-p connection user)
321 (remove-channel user channel)
322 (remove-user channel user)))))))
323
324 ;;###TODO: generate these responses in a DCC CHAT context too.
325 (macrolet ((define-ctcp-reply-hook ((message-var message-type) &body body)
326 `(defmethod default-hook ((,message-var ,message-type))
327 (when (ctcp-request-p ,message-var)
328 ,@body))))
329 (define-ctcp-reply-hook (message ctcp-time-message)
330 (multiple-value-bind
331 (second minute hour date month year day)
332 (get-decoded-time)
333 (send-irc-message
334 (connection message)
335 :notice (source message)
336 (make-ctcp-message
337 (format nil "TIME ~A"
338 (make-time-message second minute hour date month year day))))))
339 (define-ctcp-reply-hook (message ctcp-source-message)
340 (send-irc-message
341 (connection message)
342 :notice
343 (source message)
344 (make-ctcp-message
345 (format nil "SOURCE ~A:~A:~A"
346 *download-host*
347 *download-directory*
348 *download-file*))))
349 (define-ctcp-reply-hook (message ctcp-finger-message)
350 (let* ((user (user (connection message)))
351 (finger-info (if (not (zerop (length (realname user))))
352 (realname user)
353 (nickname user))))
354 (send-irc-message
355 (connection message)
356 :notice (source message)
357 (make-ctcp-message
358 (format nil "FINGER ~A" finger-info)))))
359 (define-ctcp-reply-hook (message ctcp-version-message)
360 (send-irc-message
361 (connection message)
362 :notice (source message)
363 (make-ctcp-message
364 (format nil "VERSION ~A" *ctcp-version*))))
365 (define-ctcp-reply-hook (message ctcp-ping-message)
366 (send-irc-message
367 (connection message)
368 :notice (source message)
369 (make-ctcp-message
370 (format nil "PING ~A" (car (last (arguments message))))))))
371
372 (defmethod irc-message-event (connection (message ctcp-dcc-chat-request-message))
373 (declare (ignore connection))
374 (apply-to-hooks message)
375 (client-log (connection message) message))
376 ; (when (automatically-accept-dcc-connections (configuration (connection message)))
377 ; (let* ((user (find-user (connection message) (source message)))
378 ; (args (tokenize-string (trailing-argument message)))
379 ; (remote-address (hbo-to-dotted-quad (parse-integer (fourth args))))
380 ; (remote-port (parse-integer (fifth args) :junk-allowed t)))
381 ; (push (make-dcc-connection :user user
382 ; :remote-address remote-address
383 ; :remote-port remote-port)
384 ; *dcc-connections*))))
385
386 (defmethod irc-message-event (connection (message ctcp-dcc-send-request-message))
387 (declare (ignore connection))
388 (apply-to-hooks message)
389 (client-log (connection message) message))
390 ; (when (automatically-accept-dcc-downloads (configuration (connection message)))
391 ; (let* ((user (find-user (connection message) (source message)))
392 ; (args (tokenize-string (trailing-argument message)))
393 ; (filename (third args))
394 ; (remote-address (hbo-to-dotted-quad (parse-integer (fourth args))))
395 ; (remote-port (parse-integer (fifth args)))
396 ; (filesize (parse-integer (sixth args) :junk-allowed t)))
397 ; (let ((dcc-connection (make-dcc-connection :user user
398 ; :remote-address remote-address
399 ; :remote-port remote-port)))
400 ; (with-open-file (stream filename :direction :output
401 ; :if-exists :supersede)
402 ; (write-sequence (read-message-loop dcc-connection) stream))))))
403