source: tags/0.8.1/event.lisp

Last change on this file was 179, checked in by Erik Huelsmann, 18 years ago

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