1 | ;;;; $Id: protocol.lisp 84 2005-03-20 09:54:23Z ehuelsmann $ |
---|
2 | ;;;; $Source$ |
---|
3 | |
---|
4 | ;;;; See LICENSE for licensing information. |
---|
5 | |
---|
6 | (in-package :irc) |
---|
7 | |
---|
8 | ;; |
---|
9 | ;; Condition |
---|
10 | ;; |
---|
11 | |
---|
12 | (define-condition no-such-reply () |
---|
13 | ((reply-number |
---|
14 | :reader reply-number |
---|
15 | :initarg :reply-number)) |
---|
16 | (:report (lambda (condition stream) |
---|
17 | (format stream "No such reply ~A." (reply-number condition))))) |
---|
18 | |
---|
19 | ;; |
---|
20 | ;; Connection |
---|
21 | ;; |
---|
22 | |
---|
23 | |
---|
24 | (defclass connection () |
---|
25 | ((user |
---|
26 | :initarg :user |
---|
27 | :accessor user) |
---|
28 | (server-name |
---|
29 | :initarg :server-name |
---|
30 | :accessor server-name |
---|
31 | :initform "Unknown server") |
---|
32 | (server-stream |
---|
33 | :initarg :server-stream |
---|
34 | :accessor server-stream |
---|
35 | :documentation "Stream used to talk to the IRC server.") |
---|
36 | (server-capabilities |
---|
37 | :initform *default-isupport-values* |
---|
38 | :accessor server-capabilities |
---|
39 | :documentation "Assoc array for rpl_isupport message; |
---|
40 | see http://www.irc.org/tech_docs/draft-brocklesby-irc-isupport-03.txt") |
---|
41 | (client-stream |
---|
42 | :initarg :client-stream |
---|
43 | :accessor client-stream |
---|
44 | :initform t |
---|
45 | :documentation "Messages coming back from the server is sent to |
---|
46 | this stream.") |
---|
47 | (channels |
---|
48 | :initarg :channels |
---|
49 | :accessor channels |
---|
50 | :initform (make-hash-table :test #'equal)) |
---|
51 | (hooks |
---|
52 | :initarg :hooks |
---|
53 | :accessor hooks |
---|
54 | :initform (make-hash-table :test #'equal)) |
---|
55 | (users |
---|
56 | :initarg :users |
---|
57 | :accessor users |
---|
58 | :initform (make-hash-table :test #'equal)))) |
---|
59 | |
---|
60 | (defmethod print-object ((object connection) stream) |
---|
61 | "Print the object for the Lisp reader." |
---|
62 | (print-unreadable-object (object stream :type t :identity t) |
---|
63 | (princ (server-name object) stream))) |
---|
64 | |
---|
65 | (defgeneric add-default-hooks (connection)) |
---|
66 | (defgeneric client-raw-log (connection message)) |
---|
67 | (defgeneric connectedp (connection)) |
---|
68 | (defgeneric read-message (connection)) |
---|
69 | (defgeneric start-process (function name)) |
---|
70 | (defgeneric start-background-message-handler (connection)) |
---|
71 | (defgeneric read-message-loop (connection)) |
---|
72 | (defgeneric read-irc-message (connection)) |
---|
73 | (defgeneric send-irc-message (connection command |
---|
74 | &optional trailing-argument &rest arguments)) |
---|
75 | (defgeneric get-hooks (connection class)) |
---|
76 | (defgeneric add-hook (connection class hook)) |
---|
77 | (defgeneric remove-hook (connection class hook)) |
---|
78 | (defgeneric remove-hooks (connection class)) |
---|
79 | (defgeneric remove-all-hooks (connection)) |
---|
80 | |
---|
81 | (defgeneric case-map-name (connection)) |
---|
82 | (defgeneric re-apply-case-mapping (connection)) |
---|
83 | |
---|
84 | (defun make-connection (&key (user nil) |
---|
85 | (server-name "") |
---|
86 | (server-stream nil) |
---|
87 | (client-stream t) |
---|
88 | (hooks nil)) |
---|
89 | (let ((connection (make-instance 'connection |
---|
90 | :user user |
---|
91 | :server-name server-name |
---|
92 | :server-stream server-stream |
---|
93 | :client-stream client-stream))) |
---|
94 | (dolist (hook hooks) |
---|
95 | (add-hook connection (car hook) (cadr hook))) |
---|
96 | connection)) |
---|
97 | |
---|
98 | (defmethod add-default-hooks ((connection connection)) |
---|
99 | (dolist (message '(irc-rpl_isupport-message |
---|
100 | irc-rpl_whoisuser-message |
---|
101 | irc-rpl_list-message |
---|
102 | irc-rpl_topic-message |
---|
103 | irc-rpl_namreply-message |
---|
104 | irc-ping-message |
---|
105 | irc-join-message |
---|
106 | irc-topic-message |
---|
107 | irc-part-message |
---|
108 | irc-quit-message |
---|
109 | irc-kick-message |
---|
110 | irc-nick-message |
---|
111 | ctcp-time-message |
---|
112 | ctcp-source-message |
---|
113 | ctcp-finger-message |
---|
114 | ctcp-version-message |
---|
115 | ctcp-ping-message)) |
---|
116 | (add-hook connection message #'default-hook))) |
---|
117 | |
---|
118 | (defmethod client-raw-log ((connection connection) message) |
---|
119 | (let ((stream (client-stream connection))) |
---|
120 | (format stream (format nil "RAW LOG: ~A~%" message)) |
---|
121 | (force-output stream))) |
---|
122 | |
---|
123 | (defmethod connectedp ((connection connection)) |
---|
124 | "Returns t if `connection' is connected to a server and is ready for |
---|
125 | input." |
---|
126 | (let ((stream (server-stream connection))) |
---|
127 | (and (streamp stream) |
---|
128 | (open-stream-p stream)))) |
---|
129 | |
---|
130 | (define-condition invalidate-me (condition) |
---|
131 | ((stream :initarg :stream |
---|
132 | :reader invalidate-me-stream) |
---|
133 | (condition :initarg :condition |
---|
134 | :reader invalidate-me-condition))) |
---|
135 | |
---|
136 | (defmethod read-message ((connection connection)) |
---|
137 | (let ((read-more-p t)) |
---|
138 | (handler-case |
---|
139 | (progn |
---|
140 | (when (and (connectedp connection) read-more-p) |
---|
141 | (let ((message (read-irc-message connection))) |
---|
142 | (when *debug-p* |
---|
143 | (format *debug-stream* "~A" (describe message))) |
---|
144 | (irc-message-event message) |
---|
145 | message))) ; needed because of the "loop while" in read-message-loop |
---|
146 | (stream-error (c) (setf read-more-p nil) |
---|
147 | (signal 'invalidate-me :stream |
---|
148 | (server-stream connection) |
---|
149 | :condition c))))) |
---|
150 | |
---|
151 | (defvar *process-count* 0) |
---|
152 | |
---|
153 | (defmethod start-process (function name) |
---|
154 | #+allegro (mp:process-run-function name function) |
---|
155 | #+cmu (mp:make-process function :name name) |
---|
156 | #+lispworks (mp:process-run-function name nil function) |
---|
157 | #+sb-thread (sb-thread:make-thread function) |
---|
158 | #+openmcl (ccl:process-run-function name function) |
---|
159 | #+armedbear (ext:make-thread function)) |
---|
160 | |
---|
161 | (defmethod start-background-message-handler ((connection connection)) |
---|
162 | "Read messages from the `connection', parse them and dispatch |
---|
163 | irc-message-event on them. Returns background process ID if available." |
---|
164 | (flet ((do-loop () (read-message-loop connection))) |
---|
165 | (let ((name (format nil "irc-hander-~D" (incf *process-count*)))) |
---|
166 | #+(or allegro cmu lispworks sb-thread openmcl armedbear) |
---|
167 | (start-process #'do-loop name) |
---|
168 | #+(and sbcl (not sb-thread)) |
---|
169 | (sb-sys:add-fd-handler (sb-sys:fd-stream-fd |
---|
170 | (server-stream connection)) |
---|
171 | :input (lambda (fd) |
---|
172 | (declare (ignore fd)) |
---|
173 | (handler-case |
---|
174 | (read-message connection) |
---|
175 | (invalidate-me (c) |
---|
176 | (sb-sys:invalidate-descriptor |
---|
177 | (sb-sys:fd-stream-fd |
---|
178 | (invalidate-me-stream c))) |
---|
179 | (format t "Socket closed: ~A~%" |
---|
180 | (invalidate-me-condition c))))))))) |
---|
181 | |
---|
182 | (defun stop-background-message-handler (process) |
---|
183 | "Stops a background message handler process returned by the start function." |
---|
184 | #+cmu (mp:destroy-process process) |
---|
185 | #+allegro (mp:process-kill process) |
---|
186 | #+sb-thread (sb-thread:destroy-thread process) |
---|
187 | #+lispworks (mp:process-kill process) |
---|
188 | #+openmcl (ccl:process-kill process) |
---|
189 | #+armedbear (ext:destroy-thread process)) |
---|
190 | |
---|
191 | (defmethod read-message-loop ((connection connection)) |
---|
192 | (loop while (read-message connection))) |
---|
193 | |
---|
194 | (defmethod read-irc-message ((connection connection)) |
---|
195 | "Read and parse an IRC-message from the `connection'." |
---|
196 | (let ((message (create-irc-message |
---|
197 | (read-line (server-stream connection) t)))) |
---|
198 | (setf (connection message) connection) |
---|
199 | message)) |
---|
200 | |
---|
201 | (defmethod send-irc-message ((connection connection) command |
---|
202 | &optional trailing-argument &rest arguments) |
---|
203 | "Turn the arguments into a valid IRC message and send it to the |
---|
204 | server, via the `connection'." |
---|
205 | (let ((raw-message (make-irc-message command |
---|
206 | :arguments arguments |
---|
207 | :trailing-argument trailing-argument))) |
---|
208 | (write-sequence raw-message (server-stream connection)) |
---|
209 | (force-output (server-stream connection)) |
---|
210 | raw-message)) |
---|
211 | |
---|
212 | (defmethod get-hooks ((connection connection) (class symbol)) |
---|
213 | "Return a list of all hooks for `class'." |
---|
214 | (gethash class (hooks connection))) |
---|
215 | |
---|
216 | (defmethod add-hook ((connection connection) class hook) |
---|
217 | "Add `hook' to `class'." |
---|
218 | (setf (gethash class (hooks connection)) |
---|
219 | (pushnew hook (gethash class (hooks connection))))) |
---|
220 | |
---|
221 | (defmethod remove-hook ((connection connection) class hook) |
---|
222 | "Remove `hook' from `class'." |
---|
223 | (setf (gethash class (hooks connection)) |
---|
224 | (delete hook (gethash class (hooks connection))))) |
---|
225 | |
---|
226 | (defmethod remove-hooks ((connection connection) class) |
---|
227 | "Remove all hooks for `class'." |
---|
228 | (setf (gethash class (hooks connection)) nil)) |
---|
229 | |
---|
230 | (defmethod remove-all-hooks ((connection connection)) |
---|
231 | (clrhash (hooks connection))) |
---|
232 | |
---|
233 | (defmethod case-map-name ((connection connection)) |
---|
234 | (let ((case-mapping (assoc "CASEMAPPING" (server-capabilities connection) |
---|
235 | :test #'equal))) |
---|
236 | (intern (string-upcase (second case-mapping)) (find-package "KEYWORD")))) |
---|
237 | |
---|
238 | (defmethod re-apply-case-mapping ((connection connection)) |
---|
239 | (setf (normalized-nickname (user connection)) |
---|
240 | (normalize-nickname connection (nickname (user connection)))) |
---|
241 | (flet ((set-new-users-hash (object) |
---|
242 | (let ((new-users (make-hash-table :test #'equal))) |
---|
243 | (maphash |
---|
244 | #'(lambda (norm-nick user) |
---|
245 | (declare (ignore norm-nick)) |
---|
246 | (setf (gethash |
---|
247 | (setf (normalized-nickname user) |
---|
248 | (normalize-nickname connection |
---|
249 | (nickname user))) |
---|
250 | new-users) user)) |
---|
251 | (users object)) |
---|
252 | (setf (users object) new-users)))) |
---|
253 | |
---|
254 | (set-new-users-hash connection) |
---|
255 | (let ((new-channels (make-hash-table :test #'equal))) |
---|
256 | (maphash #'(lambda (norm-name channel) |
---|
257 | (declare (ignore norm-name)) |
---|
258 | (setf (gethash |
---|
259 | (setf (normalized-name channel) |
---|
260 | (normalize-channel-name connection |
---|
261 | (name channel))) |
---|
262 | new-channels) channel) |
---|
263 | (set-new-users-hash channel)) |
---|
264 | (channels connection)) |
---|
265 | (setf (channels connection) new-channels)))) |
---|
266 | |
---|
267 | |
---|
268 | ;; |
---|
269 | ;; DCC Connection |
---|
270 | ;; |
---|
271 | |
---|
272 | (defclass dcc-connection () |
---|
273 | ((user |
---|
274 | :initarg :user |
---|
275 | :accessor user |
---|
276 | :documentation "The user at the other end of this connection. The |
---|
277 | user at this end can be reached via your normal connection object.") |
---|
278 | (stream |
---|
279 | :initarg :stream |
---|
280 | :accessor dcc-stream) |
---|
281 | (output-stream |
---|
282 | :initarg :output-stream |
---|
283 | :accessor output-stream |
---|
284 | :initform t) |
---|
285 | (socket |
---|
286 | :initarg :socket |
---|
287 | :accessor socket |
---|
288 | :documentation "The actual socket object for the connection |
---|
289 | between the two users."))) |
---|
290 | |
---|
291 | (defmethod print-object ((object dcc-connection) stream) |
---|
292 | "Print the object for the Lisp reader." |
---|
293 | (print-unreadable-object (object stream :type t :identity t) |
---|
294 | (if (user object) |
---|
295 | (format stream "with ~A@~A" |
---|
296 | (nickname (user object)) |
---|
297 | (hostname (user object))) |
---|
298 | ""))) |
---|
299 | |
---|
300 | (defun make-dcc-connection (&key (user nil) |
---|
301 | (remote-address nil) |
---|
302 | (remote-port nil) |
---|
303 | (output-stream t)) |
---|
304 | #+sbcl |
---|
305 | (let ((socket (sb-bsd-sockets:make-inet-socket :stream :tcp))) |
---|
306 | (sb-bsd-sockets:socket-connect socket remote-address remote-port) |
---|
307 | (make-instance 'dcc-connection |
---|
308 | :user user |
---|
309 | :stream (sb-bsd-sockets:socket-make-stream socket :input t :output t :buffering :none) |
---|
310 | :socket socket |
---|
311 | :output-stream output-stream)) |
---|
312 | #+openmcl |
---|
313 | (let ((socket-stream (ccl:make-socket :remote-host remote-address |
---|
314 | :remote-port remote-port))) |
---|
315 | (make-instance 'dcc-connection |
---|
316 | :user user |
---|
317 | :stream socket-stream |
---|
318 | :output-stream output-stream)) |
---|
319 | #-(or openmcl sbcl) |
---|
320 | (warn "make-dcc-connection not supported for this implementation.")) |
---|
321 | |
---|
322 | (defgeneric dcc-close (connection)) |
---|
323 | (defgeneric send-dcc-message (connection message)) |
---|
324 | |
---|
325 | (defmethod read-message ((connection dcc-connection)) |
---|
326 | (let ((message (read-line (dcc-stream connection)))) |
---|
327 | (format (output-stream connection) "~A~%" message) |
---|
328 | (force-output (output-stream connection)) |
---|
329 | message)) |
---|
330 | |
---|
331 | (defmethod read-message-loop ((connection dcc-connection)) |
---|
332 | (loop while (read-message connection))) |
---|
333 | |
---|
334 | (defmethod send-dcc-message ((connection dcc-connection) message) |
---|
335 | (format (dcc-stream connection) "~A~%" message)) |
---|
336 | |
---|
337 | ;; argh. I want to name this quit but that gives me issues with |
---|
338 | ;; generic functions. need to resolve. |
---|
339 | (defmethod dcc-close ((connection dcc-connection)) |
---|
340 | (close (dcc-stream connection)) |
---|
341 | (setf (user connection) nil) |
---|
342 | (setf *dcc-connections* (remove connection *dcc-connections*)) |
---|
343 | #+sbcl (sb-bsd-sockets:socket-close (socket connection)) |
---|
344 | ) |
---|
345 | |
---|
346 | (defmethod connectedp ((connection dcc-connection)) |
---|
347 | (let ((stream (dcc-stream connection))) |
---|
348 | (and (streamp stream) |
---|
349 | (open-stream-p stream)))) |
---|
350 | |
---|
351 | ;; |
---|
352 | ;; Channel |
---|
353 | ;; |
---|
354 | |
---|
355 | (defclass channel () |
---|
356 | ((name |
---|
357 | :initarg :name |
---|
358 | :accessor name) |
---|
359 | (normalized-name |
---|
360 | :initarg :normalized-name |
---|
361 | :accessor normalized-name) |
---|
362 | (topic |
---|
363 | :initarg :topic |
---|
364 | :accessor topic) |
---|
365 | (modes |
---|
366 | :initarg :modes |
---|
367 | :accessor modes |
---|
368 | :initform nil) |
---|
369 | (users |
---|
370 | :initarg :users |
---|
371 | :accessor users |
---|
372 | :initform (make-hash-table :test #'equal)) |
---|
373 | (user-count |
---|
374 | :initarg :user-count |
---|
375 | :accessor user-count |
---|
376 | :initform nil |
---|
377 | :documentation "May not represent the real number of users in the |
---|
378 | channel. Rather, the number returned from the LIST command gets stuck |
---|
379 | in there so the user of this library can use it for searching |
---|
380 | channels, for instance. If the value is NIL then the slot has not |
---|
381 | been populated by a LIST command."))) |
---|
382 | |
---|
383 | (defmethod print-object ((object channel) stream) |
---|
384 | "Print the object for the Lisp reader." |
---|
385 | (print-unreadable-object (object stream :type t :identity t) |
---|
386 | (princ (name object) stream))) |
---|
387 | |
---|
388 | (defun normalize-channel-name (connection string) |
---|
389 | "Normalize `string' so that it represents an all-downcased channel |
---|
390 | name." |
---|
391 | (irc-string-downcase (case-map-name connection) string)) |
---|
392 | |
---|
393 | (defun make-channel (connection |
---|
394 | &key (name "") |
---|
395 | (topic "") |
---|
396 | (modes nil) |
---|
397 | (users nil) |
---|
398 | (user-count nil)) |
---|
399 | (let ((channel |
---|
400 | (make-instance 'channel |
---|
401 | :name name |
---|
402 | :normalized-name |
---|
403 | (normalize-channel-name connection name) |
---|
404 | :topic topic |
---|
405 | :modes modes |
---|
406 | :user-count user-count))) |
---|
407 | (dolist (user users) |
---|
408 | (add-user channel user)) |
---|
409 | channel)) |
---|
410 | |
---|
411 | (defgeneric find-channel (connection channel)) |
---|
412 | (defgeneric remove-all-channels (connection)) |
---|
413 | (defgeneric add-channel (connection channel)) |
---|
414 | (defgeneric remove-channel (connection channel)) |
---|
415 | (defgeneric remove-users (channel)) |
---|
416 | |
---|
417 | (defmethod find-channel ((connection connection) (channel string)) |
---|
418 | "Return channel as designated by `channel'. If no such channel can |
---|
419 | be found, return nil." |
---|
420 | (let ((channel-name (normalize-channel-name connection channel))) |
---|
421 | (gethash channel-name (channels connection)))) |
---|
422 | |
---|
423 | (defmethod remove-all-channels ((connection connection)) |
---|
424 | "Remove all channels known to `connection'." |
---|
425 | (clrhash (channels connection))) |
---|
426 | |
---|
427 | (defmethod add-channel ((connection connection) (channel channel)) |
---|
428 | "Add `channel' to `connection'." |
---|
429 | (setf (gethash (normalized-name channel) (channels connection)) channel)) |
---|
430 | |
---|
431 | (defmethod remove-channel ((connection connection) (channel channel)) |
---|
432 | "Remove `channel' from `connection'." |
---|
433 | (remhash (normalized-name channel) (channels connection))) |
---|
434 | |
---|
435 | (defmethod remove-users ((channel channel)) |
---|
436 | "Remove all users on `channel'." |
---|
437 | (clrhash (users channel))) |
---|
438 | |
---|
439 | ;; |
---|
440 | ;; User |
---|
441 | ;; |
---|
442 | |
---|
443 | (defclass user () |
---|
444 | ((nickname |
---|
445 | :initarg :nickname |
---|
446 | :accessor nickname |
---|
447 | :initform "") |
---|
448 | (normalized-nickname |
---|
449 | :initarg :normalized-nickname |
---|
450 | :accessor normalized-nickname |
---|
451 | :initform "") |
---|
452 | (username |
---|
453 | :initarg :username |
---|
454 | :accessor username |
---|
455 | :initform "") |
---|
456 | (hostname |
---|
457 | :initarg :hostname |
---|
458 | :accessor hostname |
---|
459 | :initform "") |
---|
460 | (realname |
---|
461 | :initarg :realname |
---|
462 | :accessor realname |
---|
463 | :initform "") |
---|
464 | (channels |
---|
465 | :initarg :channels |
---|
466 | :accessor channels |
---|
467 | :initform nil))) |
---|
468 | |
---|
469 | (defmethod print-object ((object user) stream) |
---|
470 | "Print the object for the Lisp reader." |
---|
471 | (print-unreadable-object (object stream :type t :identity t) |
---|
472 | (format stream "~A!~A@~A \"~A\"" |
---|
473 | (nickname object) |
---|
474 | (username object) |
---|
475 | (hostname object) |
---|
476 | (realname object)))) |
---|
477 | |
---|
478 | (defun make-user (connection |
---|
479 | &key (nickname "") |
---|
480 | (username "") |
---|
481 | (hostname "") |
---|
482 | (realname "")) |
---|
483 | (make-instance 'user |
---|
484 | :nickname nickname |
---|
485 | :normalized-nickname (normalize-nickname connection nickname) |
---|
486 | :username username |
---|
487 | :hostname hostname |
---|
488 | :realname realname)) |
---|
489 | |
---|
490 | (defun canonicalize-nickname (connection nickname) |
---|
491 | (if (find (char nickname 0) |
---|
492 | (parse-isupport-prefix-argument |
---|
493 | (second (assoc "PREFIX" |
---|
494 | (server-capabilities connection) |
---|
495 | :test #'string=)))) |
---|
496 | (subseq nickname 1) |
---|
497 | nickname)) |
---|
498 | |
---|
499 | (defun normalize-nickname (connection string) |
---|
500 | "Normalize `string' so that represents an all-downcased IRC |
---|
501 | nickname." |
---|
502 | (irc-string-downcase (case-map-name connection) string)) |
---|
503 | |
---|
504 | (defgeneric find-user (connection nickname)) |
---|
505 | (defgeneric add-user (object user)) |
---|
506 | (defgeneric remove-all-users (connection)) |
---|
507 | (defgeneric remove-user (object user)) |
---|
508 | (defgeneric remove-user-everywhere (connection user)) |
---|
509 | (defgeneric find-or-make-user (connection nickname |
---|
510 | &key username hostname realname)) |
---|
511 | (defgeneric change-nickname (connection user new-nickname)) |
---|
512 | |
---|
513 | (defmethod find-user ((connection connection) (nickname string)) |
---|
514 | "Return user as designated by `nickname' or nil if no such user is |
---|
515 | known." |
---|
516 | (let ((nickname (normalize-nickname connection nickname))) |
---|
517 | (or (gethash nickname (users connection)) |
---|
518 | (when (string= nickname (nickname (user connection))) |
---|
519 | (user connection))))) |
---|
520 | |
---|
521 | ; what if the user is not on any channels? |
---|
522 | (defmethod add-user ((connection connection) (user user)) |
---|
523 | "Add `user' to `connection'." |
---|
524 | (setf (gethash (normalized-nickname user) (users connection)) user)) |
---|
525 | |
---|
526 | (defmethod add-user ((channel channel) (user user)) |
---|
527 | (setf (gethash (normalized-nickname user) (users channel)) user) |
---|
528 | (pushnew channel (channels user))) |
---|
529 | |
---|
530 | (defmethod remove-all-users ((connection connection)) |
---|
531 | "Remove all users known to `connection'." |
---|
532 | (clrhash (users connection))) |
---|
533 | |
---|
534 | (defmethod remove-user ((channel channel) (user user)) |
---|
535 | "Remove `user' from `channel' and `channel' from `user'." |
---|
536 | (remhash (normalized-nickname user) (users channel)) |
---|
537 | (setf (channels user) (remove channel (channels user)))) |
---|
538 | |
---|
539 | (defmethod remove-channel ((channel channel) (user user)) |
---|
540 | "Remove `channel' from `user'." |
---|
541 | (warn |
---|
542 | (concatenate 'string |
---|
543 | "use of depricated API (remove-channel channel user): " |
---|
544 | "(remove-channel user channel) is now preferred")) |
---|
545 | (remove-channel user channel)) |
---|
546 | |
---|
547 | (defmethod remove-channel ((user user) (channel channel)) |
---|
548 | "Remove `channel' from `user'." |
---|
549 | (setf (channels user) (remove channel (channels user)))) |
---|
550 | |
---|
551 | (defmethod remove-user ((connection connection) (user user)) |
---|
552 | "Remove `user' from `connection' but leave user in any channels he |
---|
553 | may be already be on." |
---|
554 | (remhash (normalized-nickname user) (users connection))) |
---|
555 | |
---|
556 | (defmethod remove-user-everywhere ((connection connection) (user user)) |
---|
557 | "Remove `user' anywhere present in the `connection'." |
---|
558 | (dolist (channel (channels user)) |
---|
559 | (remove-user channel user)) |
---|
560 | (remove-user connection user)) |
---|
561 | |
---|
562 | (defmethod find-or-make-user ((connection connection) nickname &key (username "") |
---|
563 | (hostname "") (realname "")) |
---|
564 | (or (find-user connection nickname) |
---|
565 | (make-user connection |
---|
566 | :nickname nickname |
---|
567 | :username username |
---|
568 | :hostname hostname |
---|
569 | :realname realname))) |
---|
570 | |
---|
571 | (defmethod change-nickname ((connection connection) (user user) new-nickname) |
---|
572 | (let ((new-user user) |
---|
573 | (channels (channels user))) |
---|
574 | (remove-user connection user) |
---|
575 | (setf (nickname new-user) new-nickname) |
---|
576 | (setf (normalized-nickname new-user) |
---|
577 | (normalize-nickname connection new-nickname)) |
---|
578 | (dolist (channel channels) |
---|
579 | (remove-user channel user) |
---|
580 | (add-user channel new-user)) |
---|
581 | (add-user connection user) |
---|
582 | new-user)) |
---|
583 | |
---|
584 | ;; IRC Message |
---|
585 | ;; |
---|
586 | |
---|
587 | (defclass irc-message () |
---|
588 | ((source |
---|
589 | :accessor source |
---|
590 | :initarg :source |
---|
591 | :type string) |
---|
592 | (user |
---|
593 | :accessor user |
---|
594 | :initarg :user) |
---|
595 | (host |
---|
596 | :accessor host |
---|
597 | :initarg :host |
---|
598 | :type string) |
---|
599 | (command |
---|
600 | :accessor command |
---|
601 | :initarg :command |
---|
602 | :type string) |
---|
603 | (arguments |
---|
604 | :accessor arguments |
---|
605 | :initarg :arguments |
---|
606 | :type list) |
---|
607 | (trailing-argument |
---|
608 | :accessor trailing-argument |
---|
609 | :initarg :trailing-argument |
---|
610 | :type string) |
---|
611 | (connection |
---|
612 | :accessor connection |
---|
613 | :initarg :connection) |
---|
614 | (received-time |
---|
615 | :accessor received-time |
---|
616 | :initarg :received-time) |
---|
617 | (raw-message-string |
---|
618 | :accessor raw-message-string |
---|
619 | :initarg :raw-message-string |
---|
620 | :type string))) |
---|
621 | |
---|
622 | (defmethod print-object ((object irc-message) stream) |
---|
623 | "Print the object for the Lisp reader." |
---|
624 | (print-unreadable-object (object stream :type t :identity t) |
---|
625 | (format stream "~A ~A" (source object) (command object)))) |
---|
626 | |
---|
627 | (defgeneric self-message-p (message)) |
---|
628 | (defgeneric find-irc-message-class (type)) |
---|
629 | (defgeneric client-log (connection message &optional prefix)) |
---|
630 | (defgeneric apply-to-hooks (message)) |
---|
631 | |
---|
632 | (defmethod self-message-p ((message irc-message)) |
---|
633 | "Did we send this message?" |
---|
634 | (string-equal (source message) |
---|
635 | (nickname (user (connection message))))) |
---|
636 | |
---|
637 | (defclass irc-error-reply (irc-message) ()) |
---|
638 | |
---|
639 | (eval-when (:compile-toplevel :load-toplevel :execute) |
---|
640 | (defun intern-message-symbol (prefix name) |
---|
641 | "Intern based on symbol-name to support case-sensitive mlisp" |
---|
642 | (intern |
---|
643 | (concatenate 'string |
---|
644 | (symbol-name prefix) |
---|
645 | "-" |
---|
646 | (symbol-name name) |
---|
647 | "-" |
---|
648 | (symbol-name '#:message)))) |
---|
649 | |
---|
650 | (defun define-irc-message (command) |
---|
651 | (let ((name (intern-message-symbol :irc command))) |
---|
652 | `(progn |
---|
653 | (defmethod find-irc-message-class ((type (eql ,command))) |
---|
654 | (find-class ',name)) |
---|
655 | (export ',name) |
---|
656 | (defclass ,name (irc-message) ()))))) |
---|
657 | |
---|
658 | (defmacro create-irc-message-classes (class-list) |
---|
659 | `(progn ,@(mapcar #'define-irc-message class-list))) |
---|
660 | |
---|
661 | ;; should perhaps wrap this in an eval-when? |
---|
662 | (create-irc-message-classes #.(remove-duplicates (mapcar #'second *reply-names*))) |
---|
663 | (create-irc-message-classes (:privmsg :notice :kick :topic :error :mode :ping |
---|
664 | :nick :join :part :quit :kill :pong :invite)) |
---|
665 | |
---|
666 | (defmethod find-irc-message-class (type) |
---|
667 | (declare (ignore type)) |
---|
668 | (find-class 'irc-message)) |
---|
669 | |
---|
670 | (defmethod client-log ((connection connection) (message irc-message) &optional (prefix "")) |
---|
671 | (let ((stream (client-stream connection))) |
---|
672 | (format stream "~A~A: ~A: ~A~{ ~A~} \"~A\"~%" |
---|
673 | prefix |
---|
674 | (received-time message) |
---|
675 | (command message) |
---|
676 | (source message) |
---|
677 | (arguments message) |
---|
678 | (trailing-argument message)) |
---|
679 | (force-output stream))) |
---|
680 | |
---|
681 | (defmethod apply-to-hooks ((message irc-message)) |
---|
682 | (let ((connection (connection message))) |
---|
683 | (dolist (hook (get-hooks connection (class-name (class-of message)))) |
---|
684 | (funcall hook message)))) |
---|
685 | |
---|
686 | ;; |
---|
687 | ;; CTCP Message |
---|
688 | ;; |
---|
689 | |
---|
690 | (defclass ctcp-mixin () |
---|
691 | ((ctcp-command |
---|
692 | :initarg :ctcp-command |
---|
693 | :accessor ctcp-command))) |
---|
694 | |
---|
695 | (defclass standard-ctcp-message (ctcp-mixin irc-message) ()) |
---|
696 | |
---|
697 | (defgeneric find-ctcp-message-class (type)) |
---|
698 | |
---|
699 | (eval-when (:compile-toplevel :load-toplevel :execute) |
---|
700 | (defun define-ctcp-message (ctcp-command) |
---|
701 | (let ((name (intern-message-symbol :ctcp ctcp-command))) |
---|
702 | `(progn |
---|
703 | (defmethod find-ctcp-message-class ((type (eql ,ctcp-command))) |
---|
704 | (find-class ',name)) |
---|
705 | (export ',name) |
---|
706 | (defclass ,name (ctcp-mixin irc-message) ()))))) |
---|
707 | |
---|
708 | (defmacro create-ctcp-message-classes (class-list) |
---|
709 | `(progn ,@(mapcar #'define-ctcp-message class-list))) |
---|
710 | |
---|
711 | ;; should perhaps wrap this in an eval-when? |
---|
712 | (create-ctcp-message-classes (:action :source :finger :ping |
---|
713 | :version :userinfo :time :dcc-chat-request |
---|
714 | :dcc-send-request)) |
---|
715 | |
---|
716 | (defmethod find-ctcp-message-class (type) |
---|
717 | (declare (ignore type)) |
---|
718 | (find-class 'standard-ctcp-message)) |
---|
719 | |
---|
720 | (defmethod client-log ((connection connection) (message ctcp-mixin) &optional (prefix "")) |
---|
721 | (let ((stream (client-stream connection))) |
---|
722 | (format stream "~A~A: ~A (~A): ~A~{ ~A~} \"~A\"~%" |
---|
723 | prefix |
---|
724 | (received-time message) |
---|
725 | (command message) |
---|
726 | (ctcp-command message) |
---|
727 | (source message) |
---|
728 | (arguments message) |
---|
729 | (trailing-argument message)) |
---|
730 | (force-output stream))) |
---|
731 | |
---|