protocol.lisp 1 ;;;; $Id: protocol.lisp 245 2015-09-06 13:16:49Z ehuelsmann $
2 ;;;; $URL: file:///project/cl-irc/svn/tags/0.9.2/protocol.lisp $
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
21 ;;
22 ;; Modes
23 ;;
24
25 ;; generic abstract mode class
26
27 (defclass irc-mode ()
28 ((value
29 :initarg :value
30 :accessor value
31 :initform nil)
32 (value-type
33 :initarg :value-type
34 :accessor value-type
35 :documentation "The framework sets this to `:user' or `:non-user'.
36 Essentially, if it's `:user', the value(s) held must be derived from the
37 user class.")))
38
39 (defgeneric set-mode-value (mode-object value))
40 (defgeneric unset-mode-value (mode-object value))
41 (defgeneric reset-mode-value (mode-object))
42 (defgeneric has-value-p (mode-object value &key key test))
43
44 (defmethod reset-mode-value ((mode irc-mode))
45 (setf (value mode) nil))
46
47
48 ;; mode class for holding boolean values
49
50 (defclass boolean-value-mode (irc-mode) ())
51
52 (defmethod set-mode-value ((mode boolean-value-mode) value)
53 (declare (ignore value))
54 (setf (value mode) t))
55
56 (defmethod unset-mode-value ((mode boolean-value-mode) value)
57 (declare (ignore value))
58 (setf (value mode) nil))
59
60 (defmethod has-value-p ((mode boolean-value-mode) value
61 &key key test)
62 (declare (ignore value key test))
63 (value mode))
64
65 ;; mode class for holding single values
66
67 (defclass single-value-mode (irc-mode) ())
68
69 (defmethod set-mode-value ((mode single-value-mode) value)
70 (setf (value mode) value))
71
72 (defmethod unset-mode-value ((mode single-value-mode) value)
73 (when (or (null value)
74 (equal value (value mode)))
75 (setf (value mode) nil)))
76
77 (defmethod has-value-p ((mode single-value-mode) value
78 &key (key #'identity) (test #'equal))
79 (funcall test
80 value
81 (funcall key (value mode))))
82
83
84 ;; mode class for holding lists of values
85
86 (defclass list-value-mode (irc-mode) ())
87
88 (defmethod set-mode-value ((mode list-value-mode) value)
89 (push value (value mode)))
90
91 (defmethod unset-mode-value ((mode list-value-mode) value)
92 (setf (value mode)
93 (remove value (value mode))))
94
95 (defmethod has-value-p ((mode list-value-mode) value
96 &key (key #'identity) (test #'equal))
97 (let ((key-value (funcall key value)))
98 (some #'(lambda (x)
99 (funcall test
100 key-value
101 (funcall key x)))
102 (value mode))))
103
104 ;;
105 ;; Connection
106 ;;
107
108
109 (defclass connection ()
110 ((user
111 :initarg :user
112 :accessor user)
113 (password
114 :initarg :password
115 :accessor password
116 :initform nil)
117 (server-name
118 :initarg :server-name
119 :accessor server-name
120 :initform "Unknown server")
121 (server-port
122 :initarg :server-port
123 :accessor server-port
124 :initform *default-irc-server-port*)
125 (network-stream
126 :initarg :network-stream
127 :accessor network-stream
128 :documentation "Stream used to talk binary to the IRC server.")
129 (output-stream
130 :initarg :output-stream
131 :accessor output-stream
132 :documentation "Stream used to send messages to the IRC server")
133 (server-capabilities
134 :initform *default-isupport-values*
135 :accessor server-capabilities
136 :documentation "Assoc array for rpl_isupport message;
137 see http://www.irc.org/tech_docs/draft-brocklesby-irc-isupport-03.txt")
138 (client-stream
139 :initarg :client-stream
140 :accessor client-stream
141 :initform t
142 :documentation "Messages coming back from the server are sent to
143 this stream.")
144 (dcc-offers
145 :accessor dcc-offers
146 :initform '()
147 :documentation "The DCC offers sent out in association with this
148 connection.")
149 (dcc-connections
150 :accessor dcc-connections
151 :initform '()
152 :documentation "The DCC connections associated with this IRC connection.")
153 (channels
154 :initarg :channels
155 :accessor channels
156 :initform (make-hash-table :test #'equal))
157 (hooks
158 :initarg :hooks
159 :accessor hooks
160 :initform (make-hash-table :test #'equal))
161 (channel-mode-descriptions
162 :initarg :channel-mode-descriptions
163 :accessor channel-mode-descriptions
164 :initform (chanmode-descs-from-isupport *default-isupport-values*)
165 :documentation
166 "Describes the modes an application intends to register with channels.")
167 (nick-prefixes
168 :initarg :nick-prefixes
169 :accessor nick-prefixes
170 :initform (nick-prefixes-from-isupport *default-isupport-values*))
171 (user-mode-destriptions
172 :initarg :user-mode-descriptions
173 :accessor user-mode-descriptions
174 :initform (mapcar #'(lambda (x)
175 (make-mode-description :char (car x)
176 :symbol (cdr x)))
177 *char-to-user-modes-map*)
178 :documentation
179 "Describes the modes an application intends to register with channels.")
180 (users
181 :initarg :users
182 :accessor users
183 :initform (make-hash-table :test #'equal))))
184
185 (defmethod print-object ((object connection) stream)
186 "Print the object for the Lisp reader."
187 (print-unreadable-object (object stream :type t :identity t)
188 (princ (server-name object) stream)))
189
190 (defgeneric add-default-hooks (connection))
191 (defgeneric client-raw-log (connection message))
192 (defgeneric connectedp (connection))
193 (defgeneric read-message (connection))
194 (defgeneric read-irc-message (connection))
195 (defgeneric send-irc-message (connection command &rest arguments))
196 (defgeneric get-hooks (connection class))
197 (defgeneric add-hook (connection class hook))
198 (defgeneric append-hook (connection class hook))
199 (defgeneric remove-hook (connection class hook))
200 (defgeneric remove-hooks (connection class))
201 (defgeneric remove-all-hooks (connection))
202
203 (defgeneric case-map-name (connection))
204 (defgeneric re-apply-case-mapping (connection))
205
206 (defun make-connection (&key (connection-type 'connection)
207 (user nil)
208 (password nil)
209 (server-name "")
210 (server-port nil)
211 (network-stream nil)
212 (outgoing-external-format *default-outgoing-external-format*)
213 (client-stream t)
214 (hooks nil))
215 (let* ((output-stream (flexi-streams:make-flexi-stream
216 network-stream
217 :element-type 'character
218 :external-format (external-format-fixup outgoing-external-format)))
219 (connection (make-instance connection-type
220 :user user
221 :password password
222 :server-name server-name
223 :server-port server-port
224 :network-stream network-stream
225 :output-stream output-stream
226 :client-stream client-stream)))
227 (dolist (hook hooks)
228 (add-hook connection (car hook) (cadr hook)))
229 connection))
230
231 (defmethod add-default-hooks ((connection connection))
232 (dolist (message '(irc-rpl_isupport-message
233 irc-rpl_whoisuser-message
234 irc-rpl_banlist-message
235 irc-rpl_endofbanlist-message
236 irc-rpl_exceptlist-message
237 irc-rpl_endofexceptlist-message
238 irc-rpl_invitelist-message
239 irc-rpl_endofinvitelist-message
240 irc-rpl_list-message
241 irc-rpl_topic-message
242 irc-rpl_namreply-message
243 irc-rpl_endofnames-message
244 irc-rpl_welcome-message
245 irc-ping-message
246 irc-join-message
247 irc-topic-message
248 irc-part-message
249 irc-quit-message
250 irc-kick-message
251 irc-nick-message
252 irc-mode-message
253 irc-rpl_channelmodeis-message
254 ctcp-time-message
255 ctcp-source-message
256 ctcp-finger-message
257 ctcp-version-message
258 ctcp-ping-message))
259 (add-hook connection message #'default-hook)))
260
261 (defmethod client-raw-log ((connection connection) message)
262 (let ((stream (client-stream connection)))
263 (format stream (format nil "RAW LOG: ~A~%" message))
264 (force-output stream)))
265
266 (defmethod connectedp ((connection connection))
267 "Returns t if `connection' is connected to a server and is ready for
268 input."
269 (let ((stream (network-stream connection)))
270 (and (streamp stream)
271 (open-stream-p stream))))
272
273 (defmethod read-message ((connection connection))
274 (when (connectedp connection)
275 (let ((message (read-irc-message connection)))
276 (when *debug-p*
277 (format *debug-stream* "~A" (describe message)))
278 (when message
279 (irc-message-event connection message)))
280 t)) ;; connected -> continue processing
281
282 (defvar *process-count* 0)
283
284 (defun start-process (function name)
285 "Internal helper for the DEPRECATED function
286 START-BACKGROUND-MESSAGE-HANDLER and therefore DEPRECATED itself."
287 (declare (ignorable name))
288 #+allegro (mp:process-run-function name function)
289 #+cmu (mp:make-process function :name name)
290 #+lispworks (mp:process-run-function name nil function)
291 #+sb-thread (sb-thread:make-thread function :name name)
292 #+openmcl (ccl:process-run-function name function)
293 #+armedbear (threads:make-thread function))
294
295 (defun start-background-message-handler (connection)
296 "Read messages from the `connection', parse them and dispatch
297 irc-message-event on them. Returns background process ID if available.
298
299 This function has been DEPRECATED. The function body is meant as an
300 example for library users on handling connection input. Users
301 are strongly encouraged to implement error handling (which is lacking
302 from the prototype given here."
303 (warn "START-BACKGROUND-MESSAGE-HANDLER has been deprecated and
304 is up for removal in a next release.")
305
306 #+(and sbcl (not sb-thread))
307 (flet ((select-handler (fd)
308 (declare (ignore fd))
309 (if (listen (network-stream connection))
310 (read-message connection)
311 ;; select() returns with no
312 ;; available data if the stream
313 ;; has been closed on the other
314 ;; end (EPIPE)
315 (sb-sys:invalidate-descriptor
316 (sb-sys:fd-stream-fd
317 (network-stream connection))))))
318 (sb-sys:add-fd-handler (sb-sys:fd-stream-fd
319 (network-stream connection))
320 :input #'select-handler))
321
322 #-(and sbcl (not sb-thread))
323 (flet ((do-loop ()
324 (read-message-loop connection)))
325 (let ((name (format nil "irc-handler-~D" (incf *process-count*))))
326 (start-process #'do-loop name))))
327
328 (defun stop-background-message-handler (process)
329 "Stops a background message handler process returned by the start function.
330
331 Just as its cousin START-BACKGROUND-MESSAGE-HANDLER,
332 this function is DEPRECATED."
333 (declare (ignorable process))
334 #+cmu (mp:destroy-process process)
335 #+allegro (mp:process-kill process)
336 #+sb-thread (sb-thread:terminate-thread process)
337 #+lispworks (mp:process-kill process)
338 #+openmcl (ccl:process-kill process)
339 #+armedbear (threads:destroy-thread process))
340
341 (defgeneric read-message-loop (connection))
342 (defmethod read-message-loop (connection)
343 (handler-case
344 (loop while (read-message connection))
345 (end-of-file () nil)))
346
347
348 (defmethod read-irc-message ((connection connection))
349 "Read and parse an IRC message from the `connection'."
350 (let* ((msg-string (read-protocol-line connection))
351 (message (when msg-string
352 (handler-case
353 (create-irc-message msg-string)
354 (no-such-reply ()
355 (when *unknown-reply-hook*
356 (funcall *unknown-reply-hook*
357 connection msg-string)))))))
358 (when message (setf (connection message) connection))
359 message))
360
361
362 (defmethod send-irc-message ((connection connection) command
363 &rest arguments)
364 "Turn the arguments into a valid IRC message and send it to the
365 server, via the `connection'."
366 (let ((raw-message (apply #'make-irc-message command arguments)))
367 (write-sequence raw-message (output-stream connection))
368 (force-output (output-stream connection))
369 raw-message))
370
371 ;;applies to both irc and dcc-connections
372 (defmethod get-hooks (connection (class symbol))
373 "Return a list of all hooks for `class'."
374 (gethash class (hooks connection)))
375
376 ;;applies to both irc and dcc-connections
377 (defmethod add-hook (connection class hook)
378 "Add `hook' to `class'."
379 (setf (gethash class (hooks connection))
380 (pushnew hook (gethash class (hooks connection)))))
381
382 (defmethod append-hook (connection class hook)
383 "Append `hook' to `class'."
384 (setf (gethash class (hooks connection))
385 (append (gethash class (hooks connection)) (list hook))))
386
387 (defmethod remove-hook ((connection connection) class hook)
388 "Remove `hook' from `class'."
389 (setf (gethash class (hooks connection))
390 (delete hook (gethash class (hooks connection)))))
391
392 (defmethod remove-hooks ((connection connection) class)
393 "Remove all hooks for `class'."
394 (setf (gethash class (hooks connection)) nil))
395
396 (defmethod remove-all-hooks ((connection connection))
397 (clrhash (hooks connection)))
398
399 (defmethod case-map-name ((connection connection))
400 (let ((case-mapping (assoc "CASEMAPPING" (server-capabilities connection)
401 :test #'equal)))
402 (intern (string-upcase (second case-mapping)) (find-package "KEYWORD"))))
403
404 (defmethod re-apply-case-mapping ((connection connection))
405 (setf (normalized-nickname (user connection))
406 (normalize-nickname connection (nickname (user connection))))
407 (flet ((set-new-users-hash (object)
408 (let ((new-users (make-hash-table :test #'equal)))
409 (maphash
410 #'(lambda (norm-nick user)
411 (declare (ignore norm-nick))
412 (setf (gethash
413 (setf (normalized-nickname user)
414 (normalize-nickname connection
415 (nickname user)))
416 new-users) user))
417 (users object))
418 (setf (users object) new-users))))
419
420 (set-new-users-hash connection)
421 (let ((new-channels (make-hash-table :test #'equal)))
422 (maphash #'(lambda (norm-name channel)
423 (declare (ignore norm-name))
424 (setf (gethash
425 (setf (normalized-name channel)
426 (normalize-channel-name connection
427 (name channel)))
428 new-channels) channel)
429 (set-new-users-hash channel))
430 (channels connection))
431 (setf (channels connection) new-channels))))
432
433
434 ;;
435 ;; DCC Connection
436 ;;
437
438 (defclass dcc-connection ()
439 ((irc-connection
440 :initarg :irc-connection
441 :accessor irc-connection
442 :initform nil
443 :documentation "The associated IRC connection used to send
444 CTCP control commands. When this connection is closed/lost,
445 the DCC connection should be terminated too for security reasons.")
446 (close-on-main
447 :initarg :close-on-main
448 :accessor close-on-main
449 :initform t
450 :documentation "Makes sure that the DCC connection is closed
451 as soon as either the IRC connection is actively closed or when
452 a lost connection is detected.")
453 (remote-user
454 :initarg :remote-user
455 :accessor remote-user
456 :documentation "The user at the other end of this connection. The
457 user at this end can be reached via your normal connection object.")
458 (network-stream
459 :initarg :network-stream
460 :accessor network-stream)
461 (client-stream
462 :initarg :client-stream
463 :accessor client-stream
464 :documentation "Input from the remote is sent to this stream."))
465 (:documentation "Abstract superclass of all types of DCC connections.
466
467 This class isn't meant to be instanciated. The different DCC subprotocols
468 differ widely in the way they transmit their data, meaning there are
469 relatively few methods which can be defined for this class. They do
470 share a number of properties though."))
471
472 (defmethod print-object ((object dcc-connection) stream)
473 "Print the object for the Lisp reader."
474 (print-unreadable-object (object stream :type t :identity t)
475 (if (remote-user object)
476 (format stream "with ~A@~A"
477 (nickname (remote-user object))
478 (hostname (remote-user object)))
479 "")))
480
481
482 ;; Common generic functions
483
484 ;; argh. I want to name this quit but that gives me issues with
485 ;; generic functions. need to resolve.
486 (defgeneric dcc-close (connection))
487 ;;already defined in relation to `connection':
488 ;; (defgeneric connectedp (connection))
489
490 ;; CHAT related generic functions
491 (defgeneric send-dcc-message (connection message))
492 ;;already defined in relation to `connection'
493 ;; (defgeneric read-message (connection))
494 ;;(defgeneric dcc-message-event (message)) <defined in event.lisp>
495
496 ;; SEND related generic functions
497 ;;<none yet, we don't do SEND yet...>
498 (defmethod connectedp ((connection dcc-connection))
499 (let ((stream (network-stream connection)))
500 (and (streamp stream)
501 (open-stream-p stream))))
502
503 (defmethod send-dcc-message ((connection dcc-connection) message)
504 (format (output-stream connection) "~A~%" message)
505 (force-output (network-stream connection)))
506
507 (defmethod initialize-instance :after ((instance dcc-connection)
508 &rest initargs
509 &key &allow-other-keys)
510 (push instance *dcc-connections*)
511 (when (irc-connection instance)
512 (push instance (dcc-connections (irc-connection instance)))))
513
514
515 (defmethod dcc-close ((connection dcc-connection))
516 #+(and sbcl (not sb-thread))
517 (sb-sys:invalidate-descriptor
518 (sb-sys:fd-stream-fd (network-stream connection)))
519 (ignore-errors
520 (close (network-stream connection)))
521 (setf (remote-user connection) nil
522 *dcc-connections* (remove connection *dcc-connections*)
523 (dcc-connections (irc-connection connection))
524 (remove connection (dcc-connections (irc-connection connection)))))
525
526
527 (defclass dcc-chat-connection (dcc-connection)
528 ((output-stream
529 :initarg :output-stream
530 :initform nil
531 :accessor output-stream
532 :documentation "Stream used to communicate with the other end
533 of the network pipe.")
534 (hooks
535 :initform (make-hash-table :test #'equal)
536 :accessor hooks))
537 (:documentation ""))
538
539
540 (defun make-dcc-chat-connection (&key (remote-user nil)
541 ;; (remote-address nil)
542 ;; (remote-port nil)
543 (client-stream nil)
544 (irc-connection nil)
545 (close-on-main t)
546 (network-stream nil)
547 (outgoing-external-format *default-outgoing-external-format*)
548 (hooks nil))
549 (let* ((output-stream (flexi-streams:make-flexi-stream
550 network-stream
551 :element-type 'character
552 :external-format (external-format-fixup
553 outgoing-external-format)))
554 (connection (make-instance 'dcc-chat-connection
555 :remote-user remote-user
556 :client-stream client-stream
557 :output-stream output-stream
558 :irc-connection irc-connection
559 :close-on-main close-on-main
560 :network-stream network-stream)))
561 (dolist (hook hooks)
562 (add-hook connection (car hook) (cdar hook)))
563 connection))
564
565 (defmethod read-message ((connection dcc-chat-connection))
566 (when (connectedp connection)
567 (let* ((msg-string (read-protocol-line connection))
568 (message (create-dcc-message msg-string)))
569 (setf (connection message) connection)
570 (when *debug-p*
571 (format *debug-stream* "~A" (describe message))
572 (force-output *debug-stream*))
573 (dcc-message-event connection message)
574 message))) ; needed because of the "loop while" in read-message-loop
575
576 (defmethod read-message-loop ((connection dcc-chat-connection))
577 ;; no special setup
578 (call-next-method)
579 ;; now, make sure the connection was closed and cleaned up properly...
580 ;; it *was* the last message, after all...
581 ;;##TODO, maybe we need some kind of 'auto-clean' slot to indicate
582 ;; this is the desired behaviour?
583 )
584
585
586 ;;
587 ;; Channel
588 ;;
589
590 (defclass channel ()
591 ((name
592 :initarg :name
593 :accessor name)
594 (normalized-name
595 :initarg :normalized-name
596 :accessor normalized-name)
597 (topic
598 :initarg :topic
599 :accessor topic)
600 (modes
601 :initarg :modes
602 :accessor modes
603 :initform '())
604 (visibility
605 :initarg :visibility
606 :accessor visibility
607 :initform nil
608 :type (member nil :public :private :secret :unknown))
609 (users
610 :initarg :users
611 :accessor users
612 :initform (make-hash-table :test #'equal))
613 (user-count
614 :initarg :user-count
615 :accessor user-count
616 :initform nil
617 :documentation "May not represent the real number of users in the
618 channel. Rather, the number returned from the LIST command gets stuck
619 in there so the user of this library can use it for searching
620 channels, for instance. If the value is NIL then the slot has not
621 been populated by a LIST command.")))
622
623 (defmethod print-object ((object channel) stream)
624 "Print the object for the Lisp reader."
625 (print-unreadable-object (object stream :type t :identity t)
626 (princ (name object) stream)))
627
628 (defun normalize-channel-name (connection string)
629 "Normalize `string' so that it represents an all-downcased channel
630 name."
631 (irc-string-downcase (case-map-name connection) string))
632
633 (defun make-channel (connection
634 &key (name "")
635 (topic "")
636 (modes nil)
637 (users nil)
638 (user-count nil))
639 (let ((channel
640 (make-instance 'channel
641 :name name
642 :normalized-name
643 (normalize-channel-name connection name)
644 :topic topic
645 :modes modes
646 :user-count user-count)))
647 (dolist (user users)
648 (add-user channel user))
649 channel))
650
651 (defgeneric find-channel (connection channel))
652 (defgeneric remove-all-channels (connection))
653 (defgeneric add-channel (connection channel))
654 (defgeneric remove-channel (connection channel))
655 (defgeneric remove-users (channel))
656
657 (defgeneric mode-name-from-char (connection target mode-char)
658 (:documentation "Map the mode character used in the MODE message to a
659 symbol used internally to describe the mode given a `target'."))
660
661 (defgeneric mode-description (connection target mode-name)
662 (:documentation "Retrieve a `mode-description' structure for the given
663 `mode-name' keyword."))
664
665 (defgeneric get-mode (target mode)
666 (:documentation "Get the value associated with `mode' for `target'
667 or `nil' if no mode available."))
668
669 (defgeneric set-mode (target mode &optional parameter)
670 (:documentation "Set the mode designated by the `mode' keyword to a
671 value passed in `parameter' or T if `parameter' is absent."))
672
673 (defgeneric unset-mode (target mode &optional parameter)
674 (:documentation
675 "Sets value of the mode designated by the `mode' keyword to nil.
676 If the mode holds a list of values `parameter' is used to indicate which
677 element to remove."))
678
679 (defgeneric add-mode (target mode-name mode)
680 (:documentation "Add the mode-holding object `mode-value' to `target'
681 under the access key `mode-name'.
682
683 If mode-value is a subtype of irc-mode, it is added as-is.
684 Otherwise, a mode-object will be generated from the "))
685 (defgeneric remove-mode (target mode-name)
686 (:documentation "Remove the mode-holding object in the `mode-name' key
687 from `target'."))
688
689 (defgeneric has-mode-p (target mode)
690 (:documentation "Return a generalised boolean indicating if `target' has
691 a mode `mode' associated with it."))
692
693 (defgeneric has-mode-value-p (target mode value &key key test)
694 (:documentation "Return a generalised boolean indicating if `target' has
695 a mode `mode' associated with the value `value' for given a `key' transform
696 and `test' test."))
697
698 (defmethod find-channel ((connection connection) (channel string))
699 "Return channel as designated by `channel'. If no such channel can
700 be found, return nil."
701 (let ((channel-name (normalize-channel-name connection channel)))
702 (gethash channel-name (channels connection))))
703
704 (defmethod remove-all-channels ((connection connection))
705 "Remove all channels known to `connection'."
706 (clrhash (channels connection)))
707
708 (defmethod add-channel ((connection connection) (channel channel))
709 "Add `channel' to `connection'."
710 (setf (gethash (normalized-name channel) (channels connection)) channel))
711
712 (defmethod remove-channel ((connection connection) (channel channel))
713 "Remove `channel' from `connection'."
714 (remhash (normalized-name channel) (channels connection)))
715
716 (defmethod remove-users ((channel channel))
717 "Remove all users on `channel'."
718 (clrhash (users channel))
719 (do-property-list (prop val (modes channel))
720 (when (and val (eq (value-type val) :user))
721 (remf (modes channel) prop))))
722
723 (defmethod mode-name-from-char ((connection connection)
724 (target channel) mode-char)
725 (declare (ignore target))
726 (let ((mode-desc (find mode-char (channel-mode-descriptions connection)
727 :key #'mode-desc-char)))
728 (when mode-desc
729 (mode-desc-symbol (the mode-description mode-desc)))))
730
731 (defmethod mode-description ((connection connection)
732 (target channel) mode-name)
733 (declare (ignore target))
734 (find mode-name (channel-mode-descriptions connection)
735 :key #'mode-desc-symbol))
736
737 (defgeneric make-mode (connection target mode-id))
738
739 (defmethod make-mode (connection target (mode character))
740 (let ((mode-name (mode-name-from-char connection target mode)))
741 (make-mode connection target mode-name)))
742
743 (defmethod make-mode (connection target (mode symbol))
744 (let ((mode-desc (mode-description connection target mode)))
745 (make-instance (mode-desc-class mode-desc)
746 :value-type (if (mode-desc-nick-param-p mode-desc)
747 :user :non-user))))
748
749 (defmethod add-mode (target mode-name mode)
750 (setf (getf (modes target) mode-name) mode))
751
752 (defmethod remove-mode (target mode-name)
753 (remf (modes target) mode-name))
754
755 (defmethod get-mode (target mode)
756 (let ((mode-object (has-mode-p target mode)))
757 (when mode-object
758 (value mode-object))))
759
760 (defmethod set-mode (target mode &optional parameter)
761 (set-mode-value (getf (modes target) mode) parameter))
762
763 (defmethod unset-mode (target mode &optional parameter)
764 (let ((mode (getf (modes target) mode)))
765 (when mode
766 (unset-mode-value mode parameter))))
767
768 (defmethod has-mode-p (target mode)
769 (multiple-value-bind
770 (indicator value tail)
771 (get-properties (modes target) (list mode))
772 (when (or indicator value tail)
773 value)))
774
775 (defmethod has-mode-value-p (target mode value
776 &key (key #'identity) (test #'equal))
777 (let ((mode (getf (modes target) mode)))
778 (when mode
779 (has-value-p mode value :key key :test test))))
780
781 ;;
782 ;; User
783 ;;
784
785 (defclass user ()
786 ((nickname
787 :initarg :nickname
788 :accessor nickname
789 :initform "")
790 (normalized-nickname
791 :initarg :normalized-nickname
792 :accessor normalized-nickname
793 :initform "")
794 (username
795 :initarg :username
796 :accessor username
797 :initform "")
798 (hostname
799 :initarg :hostname
800 :accessor hostname
801 :initform "")
802 (realname
803 :initarg :realname
804 :accessor realname
805 :initform "")
806 (modes
807 :initarg :modes
808 :accessor modes
809 :initform '())
810 (channels
811 :initarg :channels
812 :accessor channels
813 :initform nil)))
814
815 (defmethod print-object ((object user) stream)
816 "Print the object for the Lisp reader."
817 (print-unreadable-object (object stream :type t :identity t)
818 (format stream "~A!~A@~A \"~A\""
819 (nickname object)
820 (username object)
821 (hostname object)
822 (realname object))))
823
824 (defun make-user (connection
825 &key (nickname "")
826 (username "")
827 (hostname "")
828 (realname ""))
829 (make-instance 'user
830 :nickname nickname
831 :normalized-nickname (normalize-nickname connection nickname)
832 :username username
833 :hostname hostname
834 :realname realname))
835
836 (defun canonicalize-nickname (connection nickname)
837 (if (find (char nickname 0)
838 (parse-isupport-prefix-argument
839 (second (assoc "PREFIX"
840 (server-capabilities connection)
841 :test #'string=))))
842 (substring nickname 1)
843 nickname))
844
845 (defun normalize-nickname (connection string)
846 "Normalize `string' so that represents an all-downcased IRC
847 nickname."
848 (irc-string-downcase (case-map-name connection) string))
849
850 (defgeneric find-user (connection nickname))
851 (defgeneric add-user (object user))
852 (defgeneric remove-all-users (connection))
853 (defgeneric remove-user (object user))
854 (defgeneric remove-user-everywhere (connection user))
855 (defgeneric find-or-make-user (connection nickname
856 &key username hostname realname))
857 (defgeneric change-nickname (connection user new-nickname))
858
859 (defmethod find-user ((connection connection) (nickname string))
860 "Return user as designated by `nickname' or nil if no such user is
861 known."
862 (let ((nickname (normalize-nickname connection nickname)))
863 (or (gethash nickname (users connection))
864 (when (string= nickname (nickname (user connection)))
865 (user connection)))))
866
867 ; what if the user is not on any channels?
868 (defmethod add-user ((connection connection) (user user))
869 "Add `user' to `connection'."
870 (setf (gethash (normalized-nickname user) (users connection)) user))
871
872 (defmethod add-user ((channel channel) (user user))
873 (setf (gethash (normalized-nickname user) (users channel)) user)
874 (pushnew channel (channels user)))
875
876 (defmethod remove-all-users ((connection connection))
877 "Remove all users known to `connection'."
878 (clrhash (users connection)))
879
880 (defmethod remove-user ((channel channel) (user user))
881 "Remove `user' from `channel' and `channel' from `user'."
882 (remhash (normalized-nickname user) (users channel))
883 (setf (channels user) (remove channel (channels user)))
884 (do-property-list (prop val (modes channel))
885 (when (and val (eq (value-type val) :user))
886 (unset-mode channel prop user))))
887
888 (defmethod remove-channel ((user user) (channel channel))
889 "Remove `channel' from `user'."
890 (setf (channels user) (remove channel (channels user))))
891
892 (defmethod remove-user ((connection connection) (user user))
893 "Remove `user' from `connection' but leave user in any channels he
894 may be already be on."
895 (remhash (normalized-nickname user) (users connection)))
896
897 (defmethod remove-user-everywhere ((connection connection) (user user))
898 "Remove `user' anywhere present in the `connection'."
899 (dolist (channel (channels user))
900 (remove-user channel user))
901 (remove-user connection user))
902
903 (defmethod mode-name-from-char ((connection connection)
904 (target user) mode-char)
905 (declare (ignore target))
906 (let ((mode-desc (find mode-char (user-mode-descriptions connection)
907 :key #'mode-desc-char)))
908 (when mode-desc
909 (mode-desc-symbol (the mode-description mode-desc)))))
910
911 (defmethod mode-description ((connection connection)
912 (target user) mode-name)
913 (declare (ignore target))
914 (find mode-name (user-mode-descriptions connection)
915 :key #'mode-desc-symbol))
916
917 (defmethod find-or-make-user ((connection connection) nickname &key (username "")
918 (hostname "") (realname ""))
919 (let ((user (find-user connection nickname)))
920 (unless user
921 (setf user
922 (make-user connection
923 :nickname nickname
924 :username username
925 :hostname hostname
926 :realname realname)))
927 (labels ((update-slot-if-known (slotname value)
928 (when (string= (slot-value user slotname) "")
929 (setf (slot-value user slotname) value))))
930 (update-slot-if-known 'username username)
931 (update-slot-if-known 'hostname hostname)
932 (update-slot-if-known 'realname realname))
933 user))
934
935 (defmethod change-nickname ((connection connection) (user user) new-nickname)
936 (let ((channels (channels user)))
937 (remove-user connection user)
938 (dolist (channel channels)
939 (remove-user channel user))
940 (setf (nickname user) new-nickname)
941 (setf (normalized-nickname user)
942 (normalize-nickname connection new-nickname))
943 (dolist (channel channels)
944 (add-user channel user))
945 (add-user connection user)
946 user))
947
948 ;; IRC Message
949 ;;
950
951 (defclass irc-message ()
952 ((source
953 :accessor source
954 :initarg :source
955 :type string)
956 (user
957 :accessor user
958 :initarg :user)
959 (host
960 :accessor host
961 :initarg :host
962 :type string)
963 (command
964 :accessor command
965 :initarg :command
966 :type string)
967 (arguments
968 :accessor arguments
969 :initarg :arguments
970 :type list)
971 (connection
972 :accessor connection
973 :initarg :connection)
974 (received-time
975 :accessor received-time
976 :initarg :received-time)
977 (raw-message-string
978 :accessor raw-message-string
979 :initarg :raw-message-string
980 :type string)))
981
982 (defmethod print-object ((object irc-message) stream)
983 "Print the object for the Lisp reader."
984 (print-unreadable-object (object stream :type t :identity t)
985 (format stream "~A ~A" (source object) (command object))))
986
987 ;;Compat code; remove after 2006-08-01
988
989 (defgeneric trailing-argument (message))
990 (defmethod trailing-argument ((message irc-message))
991 (warn "Use of deprecated function irc:trailing-argument")
992 (car (last (arguments message))))
993
994 (defgeneric self-message-p (message))
995 (defgeneric user-eq-me-p (connection user))
996 (defgeneric find-irc-message-class (type))
997 (defgeneric client-log (connection message &optional prefix))
998 (defgeneric apply-to-hooks (message))
999
1000 (defmethod self-message-p ((message irc-message))
1001 "Did we send this message?"
1002 (string-equal (source message)
1003 (nickname (user (connection message)))))
1004
1005 (defmethod user-eq-me-p (connection (user user))
1006 (eq user (user connection)))
1007
1008 (defmethod user-eq-me-p (connection (user string))
1009 (let ((user (find-user connection user)))
1010 (user-eq-me-p connection user)))
1011
1012 (defclass irc-error-reply (irc-message) ())
1013
1014 (eval-when (:compile-toplevel :load-toplevel :execute)
1015 (defun intern-message-symbol (prefix name)
1016 "Intern based on symbol-name to support case-sensitive mlisp"
1017 (intern
1018 (concatenate 'string
1019 (symbol-name prefix)
1020 "-"
1021 (symbol-name name)
1022 "-"
1023 (symbol-name '#:message))))
1024
1025 (defun define-irc-message (command)
1026 (let ((name (intern-message-symbol :irc command)))
1027 `(progn
1028 (defmethod find-irc-message-class ((type (eql ,command)))
1029 (find-class ',name))
1030 (export ',name)
1031 (defclass ,name (irc-message) ())))))
1032
1033 (defmacro create-irc-message-classes (class-list)
1034 `(progn ,@(mapcar #'define-irc-message class-list)))
1035
1036 ;; should perhaps wrap this in an eval-when?
1037 (create-irc-message-classes #.(remove-duplicates (mapcar #'second *reply-names*)))
1038 (create-irc-message-classes (:privmsg :notice :kick :topic :error :mode :ping
1039 :nick :join :part :quit :kill :pong :invite))
1040
1041 (defmethod find-irc-message-class (type)
1042 (declare (ignore type))
1043 (find-class 'irc-message))
1044
1045 (defmethod client-log ((connection connection) (message irc-message) &optional (prefix ""))
1046 (let ((stream (client-stream connection)))
1047 (format stream "~A~A: ~A: ~A~{ ~A~} \"~A\"~%"
1048 prefix
1049 (received-time message)
1050 (command message)
1051 (source message)
1052 (butlast (arguments message))
1053 (car (last (arguments message))))
1054 (force-output stream)))
1055
1056 ;; applies to both irc- and dcc-messages
1057 (defmethod apply-to-hooks (message)
1058 "Applies any applicable hooks to `message'.
1059
1060 Returns non-nil if any of the hooks do."
1061 (let ((connection (connection message))
1062 (result nil))
1063 (dolist (hook (get-hooks connection (class-name (class-of message)))
1064 result)
1065 (setf result (or (funcall hook message)
1066 result)))))
1067
1068 ;;
1069 ;; DCC CHAT messages
1070 ;;
1071
1072 (defclass dcc-message ()
1073 ((connection
1074 :initarg :connection
1075 :accessor connection
1076 :documentation "")
1077 (arguments
1078 :initarg :arguments
1079 :accessor arguments
1080 :type list
1081 :documentation "")
1082 (received-time
1083 :initarg :received-time
1084 :accessor received-time)
1085 (raw-message-string
1086 :initarg :raw-message-string
1087 :accessor raw-message-string
1088 :type string))
1089 (:documentation ""))
1090
1091 (defmethod print-object ((object dcc-message) stream)
1092 "Print the object for the Lisp reader."
1093 (print-unreadable-object (object stream :type t :identity t)
1094 (format stream "~A ~A"
1095 (nickname (remote-user (connection object)))
1096 (command object))))
1097
1098 (defgeneric find-dcc-message-class (type))
1099 ;;already defined in the context of IRC messages:
1100 ;; (defgeneric client-log (connection message &optional prefix))
1101 ;; (defgeneric apply-to-hooks (message))
1102
1103
1104 (export 'dcc-privmsg-message)
1105 (defclass dcc-privmsg-message (dcc-message) ())
1106 (defmethod find-dcc-message-class ((type (eql :privmsg)))
1107 (find-class 'dcc-privmsg-message))
1108
1109 (defmethod find-dcc-message-class (type)
1110 (declare (ignore type))
1111 (find-class 'dcc-message))
1112
1113 (defmethod client-log ((connection dcc-connection)
1114 (message dcc-message) &optional (prefix ""))
1115 (let ((stream (client-stream connection)))
1116 (format stream "~A~A: ~{ ~A~} \"~A\"~%"
1117 prefix
1118 (received-time message)
1119 (butlast (arguments message))
1120 (car (last (arguments message))))
1121 (force-output stream)))
1122
1123 ;;
1124 ;; CTCP Message
1125 ;;
1126
1127 (defclass ctcp-mixin ()
1128 ((ctcp-command
1129 :initarg :ctcp-command
1130 :accessor ctcp-command)))
1131
1132 (defclass standard-ctcp-message (ctcp-mixin irc-message) ())
1133 (defclass standard-dcc-ctcp-message (ctcp-mixin dcc-message) ())
1134
1135 (defgeneric find-ctcp-message-class (type))
1136 (defgeneric find-dcc-ctcp-message-class (type))
1137 (defgeneric ctcp-request-p (message))
1138 (defgeneric ctcp-reply-p (message))
1139
1140 (eval-when (:compile-toplevel :load-toplevel :execute)
1141 (defun define-dcc-ctcp-message (ctcp-command)
1142 (let ((name (intern-message-symbol :dcc-ctcp ctcp-command)))
1143 `(progn
1144 (defmethod find-dcc-ctcp-message-class ((type (eql ,ctcp-command)))
1145 (find-class ',name))
1146 (export ',name)
1147 (defclass ,name (ctcp-mixin dcc-message) ()))))
1148 (defun define-ctcp-message (ctcp-command)
1149 (let ((name (intern-message-symbol :ctcp ctcp-command)))
1150 `(progn
1151 (defmethod find-ctcp-message-class ((type (eql ,ctcp-command)))
1152 (find-class ',name))
1153 (export ',name)
1154 (defclass ,name (ctcp-mixin irc-message) ())))))
1155
1156 (defmacro create-ctcp-message-classes (class-list)
1157 `(progn ,@(mapcar #'define-ctcp-message class-list)
1158 ,@(mapcar #'define-dcc-ctcp-message class-list)))
1159
1160 ;; should perhaps wrap this in an eval-when?
1161 (create-ctcp-message-classes (:action :source :finger :ping
1162 :version :userinfo :time :dcc-chat-request
1163 :dcc-send-request))
1164
1165 (defmethod find-ctcp-message-class (type)
1166 (declare (ignore type))
1167 (find-class 'standard-ctcp-message))
1168
1169 (defmethod find-dcc-ctcp-message-class (type)
1170 (declare (ignore type))
1171 (find-class 'standard-dcc-ctcp-message))
1172
1173 (defmethod ctcp-request-p ((message ctcp-mixin))
1174 (string= (command message) :privmsg))
1175
1176 (defmethod ctcp-request-p (message)
1177 ;; If we're not calling the above method, then, obviously
1178 ;; this was never a ctcp-thing to start with
1179 (declare (ignore message))
1180 nil)
1181
1182 (defmethod ctcp-reply-p ((message ctcp-mixin))
1183 (string= (command message) :notice))
1184
1185 (defmethod ctcp-reply-p (message)
1186 (declare (ignore message))
1187 ;; If we're not calling the above method, then, obviously
1188 ;; this was never a ctcp-thing to start with
1189 nil)
1190
1191 (defmethod client-log ((connection connection) (message ctcp-mixin) &optional (prefix ""))
1192 (let ((stream (client-stream connection)))
1193 (format stream "~A~A: ~A (~A): ~A~{ ~A~} \"~A\"~%"
1194 prefix
1195 (received-time message)
1196 (command message)
1197 (ctcp-command message)
1198 (source message)
1199 (butlast (arguments message))
1200 (car (last (arguments message))))
1201 (force-output stream)))