source: tags/0.9.0/protocol.lisp

Last change on this file was 219, checked in by Erik Huelsmann, 12 years ago

Fix long-standing complaint that cl-irc hits the debugger on unknown
(and, as Matthew Emerson puts it, irrelevant) response codes.

  • parse-message.lisp: (find-reply-name): Simply return the reply name. (create-irc-message): If there's no reply name, raise an error.
  • protocol.lisp: (read-irc-message, read-message, read-message-loop): restructure

condition handling for END-OF-FILE and NO-SUCH-REPLY to eliminate
"trickery" (returning values which mean different things than what
they are)

  • variable.lisp: (*unknown-reply-hook*): New variable for function to catch unhandled

replies. Defaults to ignore unhandled replies.

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