command.lisp 1 ;;;; $Id: command.lisp 238 2013-01-13 18:50:37Z ehuelsmann $
2 ;;;; $URL: file:///project/cl-irc/svn/tags/0.9.2/command.lisp $
3
4 ;;;; See LICENSE for licensing information.
5
6 (in-package :irc)
7
8 (defgeneric pass (connection password))
9 (defgeneric nick (connection new-nickname))
10 (defgeneric user- (connection username mode &optional realname))
11 (defgeneric oper (connection name password))
12 (defgeneric mode (connection nickname &optional mode))
13 (defgeneric op (connection channel nickname))
14 (defgeneric deop (connection channel nickname))
15 (defgeneric voice (connection channel user))
16 (defgeneric devoice (connection channel nickname))
17 (defgeneric ban (connection channel mask))
18 (defgeneric unban (connection channel mask))
19 (defgeneric service (connection nickname distribution info))
20 (defgeneric quit (connection &optional message))
21 (defgeneric squit (connection server comment))
22 (defgeneric join (connection channel &key password))
23 (defgeneric multi-join (connection channels))
24 (defgeneric part (connection channel &optional reason))
25 (defgeneric part-all (connection &optional reason))
26 (defgeneric topic- (connection channel topic))
27 (defgeneric names (connection channel &optional target))
28 (defgeneric list- (connection &optional channel target))
29 (defgeneric invite (connection user channel))
30 (defgeneric kick (connection channel user &optional comment))
31 (defgeneric privmsg (connection channel message))
32 (defgeneric notice (connection target message))
33 (defgeneric motd- (connection &optional target))
34 (defgeneric lusers (connection &optional mask target))
35 (defgeneric version (connection &optional target))
36 (defgeneric stats (connection &optional query target))
37 (defgeneric links (connection &optional remote-server server-mask))
38 (defgeneric time- (connection &optional target))
39 (defgeneric trace- (connection &optional target))
40 (defgeneric admin (connection &optional target))
41 (defgeneric info (connection &optional target))
42 (defgeneric servlist (connection &optional mask type))
43 (defgeneric squery (connection service-name text))
44 (defgeneric who (connection &optional mask o))
45 (defgeneric whois (connection mask &optional target))
46 (defgeneric whowas (connection nickname &optional count target))
47 (defgeneric kill (connection user &optional comment))
48 (defgeneric ping (connection server))
49 (defgeneric pong (connection server &optional server2))
50 (defgeneric error- (connection message))
51 (defgeneric away (connection message))
52 (defgeneric rehash (connection))
53 (defgeneric die (connection))
54 (defgeneric restart- (connection))
55 (defgeneric summon (connection nickname &optional target channel))
56 (defgeneric users- (connection &optional target))
57 (defgeneric wallops (connection message))
58 (defgeneric userhost (connection nickname))
59 (defgeneric ison (connection user))
60 (defgeneric action (connection target message))
61 (defgeneric ctcp (connection target message))
62 (defgeneric ctcp-reply (connection target message))
63 (defgeneric ctcp-chat-initiate (connection nickname &key passive)
64 (:documentation "Initiate a DCC chat session with `nickname' associated
65 with `connection'.
66
67 If `passive' is non-NIL, the remote is requested to serve as a DCC
68 host. Otherwise, the local system will serve as a DCC host. The
69 latter may be a problem for firewalled or NATted hosts."))
70 (defgeneric dcc-request-accept (message)
71 (:documentation ""))
72 (defgeneric dcc-request-reject (message &optional reason)
73 (:documentation ""))
74 (defgeneric dcc-request-cancel (connection token)
75 (:documentation ""))
76
77
78 (defmethod pass ((connection connection) (password string))
79 "A \"PASS\" command is not required for a client connection to be
80 registered, but it MUST precede the latter of the NICK/USER
81 combination (for a user connection) or the SERVICE command (for a
82 service connection). The RECOMMENDED order for a client to register is
83 as follows:
84
85 1. Pass message
86 2. Nick message 2. Service message
87 3. User message
88
89 Upon success, the client will receive an RPL_WELCOME (for users) or
90 RPL_YOURESERVICE (for services) message indicating that the connection
91 is now registered and known the to the entire IRC network. The reply
92 message MUST contain the full client identifier upon which it was
93 registered."
94 (send-irc-message connection :pass password))
95
96 (defmethod nick ((connection connection) (new-nickname string))
97 (send-irc-message connection :nick new-nickname))
98
99 (defmethod user- ((connection connection) (username string)
100 (mode integer) &optional (realname ""))
101 (send-irc-message connection :user username mode "*" realname))
102
103 (defmethod oper ((connection connection) (name string) (password string))
104 (send-irc-message connection :oper name password))
105
106 (defmethod mode ((connection connection) (nickname string) &optional mode)
107 (send-irc-message connection :mode nickname mode))
108
109 ;; utility functions not part of the RFCs
110 (defmethod op ((connection connection) (channel string) (nickname string))
111 (send-irc-message connection :mode channel "+o" nickname))
112
113 (defmethod op ((connection connection) (channel channel) (user user))
114 (op connection (name channel) (nickname user)))
115
116 (defmethod deop ((connection connection) (channel string) (nickname string))
117 (send-irc-message connection :mode channel "-o" nickname))
118
119 (defmethod deop ((connection connection) (channel channel) (user user))
120 (deop connection (name channel) (nickname user)))
121
122 (defmethod voice ((connection connection) (channel string) (nickname string))
123 (send-irc-message connection :mode channel "+v" nickname))
124
125 (defmethod voice ((connection connection) (channel channel) (user user))
126 (voice connection (name channel) (nickname user)))
127
128 (defmethod devoice ((connection connection) (channel string) (nickname string))
129 (send-irc-message connection :mode channel "-v" nickname))
130
131 (defmethod devoice ((connection connection) (channel channel) (user user))
132 (devoice connection (name channel) (nickname user)))
133
134 (defmethod ban ((connection connection) (channel string) (mask string))
135 (send-irc-message connection :mode channel "+b" mask))
136
137 (defmethod ban ((connection connection) (channel channel) (mask string))
138 (ban connection (name channel) mask))
139
140 ;; unban or deban?
141 (defmethod unban ((connection connection) (channel string) (mask string))
142 (send-irc-message connection :mode channel "-b" mask))
143
144 (defmethod unban ((connection connection) (channel channel) (mask string))
145 (unban connection (name channel) mask))
146
147 (defmethod service ((connection connection) (nickname string)
148 (distribution string) (info string))
149 (send-irc-message connection :service nickname "*" distribution 0 0 info))
150
151 (defmethod quit ((connection connection) &optional (message *default-quit-message*))
152 (remove-all-channels connection)
153 (remove-all-users connection)
154 (dolist (dcc (dcc-connections connection))
155 (when (close-on-main dcc)
156 (quit dcc "Main IRC server connection lost.")))
157 (unwind-protect
158 (send-irc-message connection :quit message)
159 #+(and sbcl (not sb-thread))
160 (sb-sys:invalidate-descriptor (sb-sys:fd-stream-fd
161 (network-stream connection)))
162 (close (network-stream connection))))
163
164 (defmethod squit ((connection connection) (server string) (comment string))
165 (send-irc-message connection :squit server comment))
166
167 (defmethod join ((connection connection) (channel string) &key password)
168 (apply #'send-irc-message
169 connection :join channel (when password (list password))))
170
171 (defmethod join ((connection connection) (channel channel) &key password)
172 (join connection (name channel) :password password))
173
174 ;; utility function not part of the RFC
175 (defmethod multi-join ((connection connection) (channels list))
176 (dolist (channel channels)
177 (join connection channel)))
178
179 (defmethod part ((connection connection) (channel string) &optional reason)
180 (apply #'send-irc-message
181 connection :part channel (when reason (list reason))))
182
183 (defmethod part ((connection connection) (channel channel) &optional reason)
184 (part connection (name channel) reason))
185
186 ;; utility function not part of the RFC
187 (defmethod part-all ((connection connection) &optional reason)
188 (maphash #'(lambda (chan obj)
189 (declare (ignore obj))
190 (part connection chan reason))
191 (channels connection)))
192
193 (defmethod topic- ((connection connection) (channel string) (topic string))
194 (send-irc-message connection :topic channel topic))
195
196 (defmethod topic- ((connection connection) (channel channel) (topic string))
197 (topic- connection (name channel) topic))
198
199 (defmethod names ((connection connection) (channel string)
200 &optional (target ""))
201 (send-irc-message connection :names channel target))
202
203 (defmethod names ((connection connection) (channel channel)
204 &optional (target ""))
205 (names connection (name channel) target))
206
207 (defmethod list- ((connection connection) &optional
208 (channel "") (target ""))
209 (send-irc-message connection :list channel target))
210
211 (defmethod invite ((connection connection) (nickname string) (channel string))
212 (send-irc-message connection :invite nickname channel))
213
214 (defmethod invite ((connection connection) (user user) (channel channel))
215 (invite connection (nickname user) (name channel)))
216
217 (defmethod kick ((connection connection) (channel string)
218 (user string) &optional (comment ""))
219 (send-irc-message connection :kick channel user comment))
220
221 (defmethod kick ((connection connection) (channel channel)
222 (user user) &optional (comment ""))
223 (kick connection (name channel) (nickname user) comment))
224
225 (defmethod privmsg ((connection connection) (target string) (message string))
226 (send-irc-message connection :privmsg target message))
227
228 (defmethod privmsg ((connection connection) (user user) (message string))
229 (privmsg connection (nickname user) message))
230
231 (defmethod privmsg ((connection connection) (channel channel) (message string))
232 (privmsg connection (name channel) message))
233
234 (defmethod privmsg ((connection dcc-chat-connection) target message)
235 (declare (ignore target))
236 (send-dcc-message connection message))
237
238 (defmethod notice ((connection connection) (target string) (message string))
239 (send-irc-message connection :notice target message))
240
241 (defmethod notice ((connection connection) (user user) (message string))
242 (notice connection (nickname user) message))
243
244 (defmethod notice ((connection connection) (channel channel) (message string))
245 (notice connection (name channel) message))
246
247 (defmethod motd- ((connection connection) &optional (target ""))
248 (send-irc-message connection :motd target))
249
250 (defmethod lusers ((connection connection) &optional (mask "") (target ""))
251 (send-irc-message connection :lusers mask target))
252
253 (defmethod version ((connection connection) &optional (target ""))
254 (send-irc-message connection :version target))
255
256 (defmethod stats ((connection connection) &optional (query "") (target ""))
257 (send-irc-message connection :stats query target))
258
259 (defmethod links ((connection connection) &optional (remote-server "")
260 (server-mask ""))
261 (send-irc-message connection :links remote-server server-mask))
262
263 (defmethod time- ((connection connection) &optional (target ""))
264 (send-irc-message connection :time target))
265
266 (defun connect (&key (nickname *default-nickname*)
267 (username nil)
268 (realname nil)
269 (password nil)
270 (mode 0)
271 (server *default-irc-server*)
272 (port :default)
273 (connection-type 'connection)
274 (connection-security :none)
275 (logging-stream t))
276 "Connect to server and return a connection object.
277
278 `port' and `connection-security' have a relation: when `port' equals
279 `:default' `*default-irc-server-port*' is used to find which port to
280 connect to. `connection-security' determines which port number is found.
281
282 `connection-security' can be either `:none' or `:ssl'. When passing
283 `:ssl', the cl+ssl library must have been loaded by the caller.
284 "
285 (let* ((port (if (eq port :default)
286 ;; get the default port for this type of connection
287 (getf *default-irc-server-port* connection-security)
288 port))
289 (socket (usocket:socket-connect server port
290 :element-type 'flexi-streams:octet))
291 (stream (if (eq connection-security :ssl)
292 (dynfound-funcall (make-ssl-client-stream :cl+ssl)
293 (usocket:socket-stream socket))
294 (usocket:socket-stream socket)))
295 (connection (make-connection :connection-type connection-type
296 :network-stream stream
297 :client-stream logging-stream
298 :server-name server)))
299 ;; #+sbcl (setf (sb-bsd-sockets::sockopt-keep-alive (usocket:socket socket)) t)
300 #+sbcl (setf (sb-bsd-sockets::sockopt-tcp-nodelay (usocket:socket socket)) t)
301 #+sbcl (setf (sb-bsd-sockets::sockopt-tcp-quickack (usocket:socket socket)) t)
302 #+sbcl (setf (sb-impl::fd-stream-timeout (usocket:socket-stream socket))
303 (coerce 150 'single-float))
304 (unless (null password)
305 (pass connection password))
306 (nick connection nickname)
307 (user- connection (or username nickname) mode (or realname nickname))
308 (add-default-hooks connection)
309 connection))
310
311 (defmethod trace- ((connection connection) &optional (target ""))
312 (send-irc-message connection :trace target))
313
314 (defmethod admin ((connection connection) &optional (target ""))
315 (send-irc-message connection :admin target))
316
317 (defmethod info ((connection connection) &optional (target ""))
318 (send-irc-message connection :info target))
319
320 (defmethod servlist ((connection connection) &optional (mask "") (type ""))
321 (send-irc-message connection :servlist mask type))
322
323 (defmethod squery ((connection connection) (service-name string) (text string))
324 (send-irc-message connection :squery text service-name))
325
326 (defmethod who ((connection connection) &optional (mask "") (o ""))
327 (send-irc-message connection :who mask o))
328
329 (defmethod whois ((connection connection) (mask string) &optional (target ""))
330 (send-irc-message connection :whois target mask))
331
332 (defmethod whowas ((connection connection) (nickname string)
333 &optional (count "") (target ""))
334 (send-irc-message connection :whowas nickname count target))
335
336 (defmethod kill ((connection connection) (nickname string) &optional (comment ""))
337 (send-irc-message connection :kill comment nickname))
338
339 (defmethod kill ((connection connection) (user user) &optional (comment ""))
340 (kill connection (nickname user) comment))
341
342 (defmethod ping ((connection connection) (server string))
343 (send-irc-message connection :ping server))
344
345 (defmethod pong ((connection connection) (server string) &optional server2)
346 (if server2
347 (send-irc-message connection :pong server server2)
348 (send-irc-message connection :pong server)))
349
350 (defmethod error- ((connection connection) (message string))
351 (send-irc-message connection :error message))
352
353 (defmethod away ((connection connection) (message string))
354 (send-irc-message connection :away message))
355
356 (defmethod rehash ((connection connection))
357 (send-irc-message connection :rehash))
358
359 (defmethod die ((connection connection))
360 (send-irc-message connection :die))
361
362 (defmethod restart- ((connection connection))
363 (send-irc-message connection :restart))
364
365 (defmethod summon ((connection connection) (nickname string)
366 &optional (target "") (channel ""))
367 (send-irc-message connection :summon nickname target channel))
368
369 (defmethod users- ((connection connection) &optional (target ""))
370 (send-irc-message connection :users target))
371
372 (defmethod wallops ((connection connection) (message string))
373 (send-irc-message connection :wallops message))
374
375 (defmethod userhost ((connection connection) (nickname string))
376 (send-irc-message connection :userhost nickname))
377
378 (defmethod userhost ((connection connection) (user user))
379 (userhost connection (nickname user)))
380
381 (defmethod ison ((connection connection) (nickname string))
382 (send-irc-message connection :ison nickname))
383
384 (defmethod ison ((connection connection) (user user))
385 (ison connection (nickname user)))
386
387 ;; utility functions not part of the RFC
388 (defmethod ctcp ((connection connection) target message)
389 (send-irc-message connection :privmsg target (make-ctcp-message message)))
390
391 (defmethod ctcp-reply ((connection connection) target message)
392 (send-irc-message connection :notice target (make-ctcp-message message)))
393
394 (defmethod action ((connection connection) (target string) (message string))
395 (ctcp connection target (concatenate 'string "ACTION " message)))
396
397 (defmethod action ((connection connection) (user user) (message string))
398 (action connection (nickname user) message))
399
400 (defmethod action ((connection connection) (channel channel) (message string))
401 (action connection (name channel) message))
402
403
404 ;; Intermezzo: Manage outstanding offers
405
406 (defvar *passive-offer-sequence-token* 0)
407
408 (defgeneric dcc-add-offer (connection nickname type token &optional proto)
409 (:documentation "Adds an offer to the list off outstanding offers list
410 for `connection'."))
411
412 (defgeneric dcc-remove-offer (connection token)
413 ;; Tokens are uniquely defined within the scope of the library,
414 ;; so we don't need anything but the token to actually remove an offer
415 (:documentation "Remove an offer from the list of outstanding offers
416 for `connection'."))
417
418 (defgeneric dcc-get-offer (connection token))
419 (defgeneric dcc-get-offers (connection nickname &key type token))
420
421 (defun matches-offer-by-token-p (offer token)
422 (equal (third offer) token))
423
424 (defun matches-offer-by-user-p (offer user)
425 (equal (first offer) user))
426
427 (defun offer-matches-message-p (offer message-nick message-type message-token)
428 (and (equal (first offer) message-nick)
429 (equal (second offer) message-type)
430 (equal (third offer) message-token)))
431
432 (defmethod dcc-add-offer (connection nickname type token &optional proto)
433 (push (list nickname type token) (dcc-offers connection)))
434
435 (defmethod dcc-remove-offer (connection token)
436 (setf (dcc-offers connection)
437 (remove-if #'(lambda (x)
438 (matches-offer-by-token-p x token))
439 (dcc-offers connection))))
440
441 (defmethod dcc-get-offer (connection token)
442 (let ((offer-list (remove-if #'(lambda (x)
443 (not (equal (third x) token)))
444 (dcc-offers connection))))
445 (first offer-list)))
446
447 (defmethod dcc-get-offers (connection nickname &key type token)
448 (let* ((results (remove-if #'(lambda (x)
449 (not (matches-offer-by-user-p x nickname)))
450 (dcc-offers connection)))
451 (results (if type
452 (remove-if #'(lambda (x)
453 (not (equal type (second x)))) results)
454 results))
455 (results (if token
456 (remove-if #'(lambda (x)
457 (not (equal token (third x)))) results))))
458 results))
459
460 ;; End of intermezzo
461
462 ;;
463 ;; And we move on with the definitions required to manage the protocol
464 ;;
465
466 (defmethod ctcp-chat-initiate ((connection connection) (nickname string)
467 &key passive)
468 (if passive
469 ;; do passive request
470 (let ((token (princ-to-string (incf *passive-offer-sequence-token*))))
471 ;; tokens have been specified to be integer values,
472 (dcc-add-offer connection nickname "CHAT" token)
473 (ctcp connection nickname
474 (format nil "DCC CHAT CHAT ~A 0 ~A"
475 (usocket:host-byte-order #(1 1 1 1))
476 token))
477 token)
478 ;; or do active request
479 (error "Active DCC initiating not (yet) supported.")))
480
481 (defmethod ctcp-chat-initiate ((connection dcc-chat-connection)
482 nickname &key passive)
483 (declare (ignore nickname passive))
484 (error "Chat connection already in progress"))
485
486 (defmethod dcc-request-cancel ((connection connection) token)
487 (dcc-remove-offer connection token)
488 (if (stringp token)
489 (let ((offer (dcc-get-offer connection token)))
490 ;; We have a passive request; active ones have an associated
491 ;; socket instead...
492 (ctcp-reply connection (first offer)
493 (format nil "DCC REJECT ~A ~A" (second offer) token)))
494 (progn
495 ;; do something to close the socket here...
496 ;; OTOH, we don't support active sockets (yet), so, comment out.
497 #|
498 (usocket:socket-close token)
499 (ctcp-reply connection nickname (format nil
500 "ERRMSG DCC ~A timed out" type))
501 |#
502 )))
503
504 (defmethod dcc-request-cancel ((connection dcc-chat-connection) token)
505 (dcc-request-cancel (irc-connection connection) token))
506
507 (defmethod dcc-request-accept ((message ctcp-dcc-chat-request-message))
508 ;; There are 2 options here: it was an active dcc offer or a passive one
509 ;; For now, we'll support only active offers (where we act as a client)
510 (let* ((raw-offer (car (last (arguments message))))
511 (clean-offer (string-trim (list +soh+) raw-offer))
512 (args (tokenize-string clean-offer))
513 (remote-ip (ignore-errors (parse-integer (fourth args))))
514 (remote-port (ignore-errors (parse-integer (fifth args))))
515 (their-token (sixth args))
516 (irc-connection (connection message)))
517 (when (string= (string-upcase (third args)) "CHAT")
518 (if (= remote-port 0)
519 ;; a passive chat request, which we don't support (yet):
520 ;; we don't act as a server yet
521 (ctcp-reply irc-connection (source message)
522 "ERRMSG DCC CHAT passive-CHAT unavailable")
523 (progn
524 (when their-token
525 (let ((offer (dcc-get-offer irc-connection their-token)))
526 (when (or (null offer)
527 (not (offer-matches-message-p offer
528 (source message)
529 "CHAT" their-token)))
530 (ctcp-reply irc-connection (source message)
531 (format nil
532 "ERRMSG DCC CHAT invalid token (~A)"
533 their-token))
534 (return-from dcc-request-accept))))
535 ;; ok, so either there was no token, or it matches
536 ;;
537 ;; When there was no token, but there was a chat request
538 ;; with the same nick and type, maybe we achieved the same
539 ;; in the end. (This would be caused by the other side
540 ;; initiating the request manually after the client blocked
541 ;; and automatic response.
542 (let ((offers (dcc-get-offers irc-connection (source message)
543 :type "CHAT")))
544 (when offers
545 ;; if there are more offers, consider the first fulfilled.
546 (dcc-remove-offer irc-connection (third (first offers)))))
547
548 (let ((socket (unless (or (null remote-ip)
549 (null remote-port)
550 (= 0 remote-port))
551 (usocket:socket-connect
552 remote-ip remote-port
553 :element-type 'flexi-streams:octet))))
554 (dcc-remove-offer irc-connection their-token)
555 (make-dcc-chat-connection
556 :irc-connection irc-connection
557 :remote-user (find-user irc-connection (source message))
558 :network-stream (usocket:socket-stream socket))))))))
559
560 (defmethod dcc-request-accept ((message dcc-ctcp-dcc-chat-request-message))
561 (error "DCC Chat already in progress"))
562
563 (defmethod dcc-request-reject ((message ctcp-dcc-chat-request-message)
564 &optional reason)
565 (ctcp-reply (connection message) (source message)
566 (format nil "ERRMSG DCC CHAT ~A" (if reason reason
567 "rejected"))))
568
569 (defmethod dcc-request-reject ((message dcc-ctcp-dcc-chat-request-message)
570 &optional reason)
571 (ctcp-reply (irc-connection (connection message))
572 (nickname (user (connection message)))
573 (format nil "ERRMSG DCC CHAT ~A" (if reason reason
574 "rejected"))))
575
576 ;;
577 ;; IRC commands which make some sence in a DCC CHAT context
578 ;;
579
580 (defmethod quit ((connection dcc-chat-connection)
581 &optional message)
582 (when message
583 (ignore-errors (send-dcc-message connection message)))
584 (ignore-errors
585 (dcc-close connection)))
586
587 ;;## TODO
588 ;; ctcp action, time, source, finger, ping+pong message generation
589 ;; btw: those could be defined for 'normal' IRC too; currently
590 ;; we only generate the responses to others' messages.