source: tags/0.9.2/event.lisp

Last change on this file was 243, checked in by jdanjou, 11 years ago

Set namreply-in-progress even on connection user

If not set, the user will be remove from the channel when handling the
endofnames reply, even if it is present in the channel, building invalid
data.

Signed-off-by: Julien Danjou <julien@…>

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision URL
File size: 16.7 KB
Line 
1;;;; $Id: event.lisp 243 2013-07-01 20:16:35Z jdanjou $
2;;;; $URL: 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
10connection's stream, irc-message-event will be called with the
11message."))
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
20connection's stream, irc-message-event will be called with the
21message."))
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
31of the IRC message to keep the connection, channel and user
32objects 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 
Note: See TracBrowser for help on using the repository browser.