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