Update of /project/net-nittin-irc/cvsroot/net-nittin-irc In directory common-lisp.net:/tmp/cvs-serv3226

Modified Files: command.lisp event.lisp net-nittin-irc.asd package.lisp parse-message.lisp protocol.lisp utility.lisp variable.lisp Log Message: - the beginnings of DCC support

- I entirely rewrote the parsing functions and we should now have much more maintainable code. The new code might be a tad slower but until someone can prove they need the speed or have a patch that doesn't impact maintainability too much I don't see a reason for optimizing it any.

Date: Fri Nov 7 08:43:06 2003 Author: eenge

Index: net-nittin-irc/command.lisp diff -u net-nittin-irc/command.lisp:1.1.1.1 net-nittin-irc/command.lisp:1.2 --- net-nittin-irc/command.lisp:1.1.1.1 Mon Nov 3 12:00:54 2003 +++ net-nittin-irc/command.lisp Fri Nov 7 08:43:06 2003 @@ -1,4 +1,4 @@ -;;;; $Id: command.lisp,v 1.1.1.1 2003/11/03 17:00:54 eenge Exp $ +;;;; $Id: command.lisp,v 1.2 2003/11/07 13:43:06 eenge Exp $ ;;;; $Source: /project/net-nittin-irc/cvsroot/net-nittin-irc/command.lisp,v $

;;;; See LICENSE for licensing information. @@ -190,7 +190,9 @@ :element-type 'character) #+allegro (socket:make-socket :remote-host server :remote-port port) #+sbcl (connect-to-server-socket server port)) - (user (make-user :nickname nickname)) + (user (make-user :nickname nickname + :username username + :realname realname)) (connection (make-connection :server-stream stream :user user :server-name server))) @@ -272,6 +274,27 @@ (defmethod ison ((connection connection) (user user)) (ison connection (nickname user)))

-;; utility function not part of the RFC +;; utility functions not part of the RFC (defmethod ctcp ((connection connection) target message) - (send-irc-message connection :privmsg (make-ctcp-message message) target)) \ No newline at end of file + (send-irc-message connection :privmsg (make-ctcp-message message) target)) + +(defmethod ctcp-chat-initiate ((connection connection) (nickname string)) + (let ((socket (sb-bsd-sockets:make-inet-socket :stream :tcp)) + (port 44347)) + (sb-bsd-sockets:socket-bind socket #(127 0 0 1) port) ; arbitrary port + (sb-bsd-sockets:socket-listen socket 1) ; accept one connection + (ctcp connection nickname + (format nil "DCC CHAT chat ~A ~A" + ; the use of hostname here is incorrect (it could be a firewall's IP) + (host-byte-order (hostname (user connection))) port)) + (make-dcc-connection :user (find-user connection nickname) + :input-stream t + :output-stream (sb-bsd-sockets:socket-make-stream socket :input t :output t :buffering :none) + :socket socket))) + +(defmethod ctcp-chat-accept ((connection connection) nickname hostname port) + (let ((socket (sb-bsd-sockets:make-inet-socket :stream :tcp))) + (sb-bsd-sockets:socket-connect socket hostname port) + (make-dcc-connection :user (find-user connection nickname) + :stream (sb-bsd-sockets:socket-make-stream socket :input t :output t :buffering :none) + :socket socket))) \ No newline at end of file

Index: net-nittin-irc/event.lisp diff -u net-nittin-irc/event.lisp:1.3 net-nittin-irc/event.lisp:1.4 --- net-nittin-irc/event.lisp:1.3 Mon Nov 3 16:04:41 2003 +++ net-nittin-irc/event.lisp Fri Nov 7 08:43:06 2003 @@ -1,4 +1,4 @@ -;;;; $Id: event.lisp,v 1.3 2003/11/03 21:04:41 eenge Exp $ +;;;; $Id: event.lisp,v 1.4 2003/11/07 13:43:06 eenge Exp $ ;;;; $Source: /project/net-nittin-irc/cvsroot/net-nittin-irc/event.lisp,v $

;;;; See LICENSE for licensing information. @@ -290,7 +290,14 @@

(defmethod irc-message-event ((message irc-rpl_whoisuser-message)) (apply-to-hooks message) - (client-log (connection message) message)) + (client-log (connection message) message) + (let ((user (find-user (connection message) (second (arguments message)))) + (realname (trailing-argument message)) + (username (third (arguments message))) + (hostname (fourth (arguments message)))) + (setf (realname user) realname) + (setf (username user) username) + (setf (hostname user) hostname)))

(defmethod irc-message-event ((message irc-rpl_whoisserver-message)) (apply-to-hooks message) @@ -814,7 +821,7 @@ (defmethod irc-message-event ((message irc-ping-message)) (apply-to-hooks message) (client-log (connection message) message) - (pong (trailing-argument message) (connection message))) + (pong (connection message) (trailing-argument message) ))

(defmethod irc-message-event ((message irc-error-message)) (apply-to-hooks message)

Index: net-nittin-irc/net-nittin-irc.asd diff -u net-nittin-irc/net-nittin-irc.asd:1.1.1.1 net-nittin-irc/net-nittin-irc.asd:1.2 --- net-nittin-irc/net-nittin-irc.asd:1.1.1.1 Mon Nov 3 12:00:54 2003 +++ net-nittin-irc/net-nittin-irc.asd Fri Nov 7 08:43:06 2003 @@ -1,4 +1,4 @@ -;;;; $Id: net-nittin-irc.asd,v 1.1.1.1 2003/11/03 17:00:54 eenge Exp $ +;;;; $Id: net-nittin-irc.asd,v 1.2 2003/11/07 13:43:06 eenge Exp $ ;;;; $Source: /project/net-nittin-irc/cvsroot/net-nittin-irc/net-nittin-irc.asd,v $

;;;; See the LICENSE file for licensing information. @@ -16,7 +16,8 @@ :version "0.1.0" :licence "MIT" :description "Common Lisp interface to the IRC protocol" - #+sbcl :depends-on (:sb-bsd-sockets) + #+sbcl :depends-on (:sb-bsd-sockets :split-sequence) + :depends-on (:split-sequence) :components ((:file "package") (:file "variable" :depends-on ("package"))

Index: net-nittin-irc/package.lisp diff -u net-nittin-irc/package.lisp:1.2 net-nittin-irc/package.lisp:1.3 --- net-nittin-irc/package.lisp:1.2 Mon Nov 3 15:56:18 2003 +++ net-nittin-irc/package.lisp Fri Nov 7 08:43:06 2003 @@ -1,4 +1,4 @@ -;;;; $Id: package.lisp,v 1.2 2003/11/03 20:56:18 eenge Exp $ +;;;; $Id: package.lisp,v 1.3 2003/11/07 13:43:06 eenge Exp $ ;;;; $Source: /project/net-nittin-irc/cvsroot/net-nittin-irc/package.lisp,v $

;;;; See the LICENSE file for licensing information. @@ -11,9 +11,10 @@ (:nicknames :irc) (:export :read-message-loop :read-message - :send-irc-message + :send-message :add-hook :remove-hook + :remove-hooks :get-hooks :make-user :make-connection

Index: net-nittin-irc/parse-message.lisp diff -u net-nittin-irc/parse-message.lisp:1.1.1.1 net-nittin-irc/parse-message.lisp:1.2 --- net-nittin-irc/parse-message.lisp:1.1.1.1 Mon Nov 3 12:00:54 2003 +++ net-nittin-irc/parse-message.lisp Fri Nov 7 08:43:06 2003 @@ -1,4 +1,4 @@ -;;;; $Id: parse-message.lisp,v 1.1.1.1 2003/11/03 17:00:54 eenge Exp $ +;;;; $Id: parse-message.lisp,v 1.2 2003/11/07 13:43:06 eenge Exp $ ;;;; $Source: /project/net-nittin-irc/cvsroot/net-nittin-irc/parse-message.lisp,v $

;;;; See the LICENSE file for licensing information. @@ -14,89 +14,53 @@ 'no-such-reply :reply-number reply-number) :unknown-reply))))

-(declaim (inline parse-irc-message-1)) -(defun parse-irc-message-1 (raw-message-string) - (let ((index 0)) - (macrolet ((accept-char (char) - `(when (eql (char raw-message-string index) ,char) - (incf index) - ,char)) - (accept-to-chars (&rest chars) - `(let ((start index) - (end (position-if (lambda (char) (find char ',chars)) raw-message-string - :start index))) - (when end - (setf index end) - (subseq raw-message-string start end))))) - (labels ((accept-source () - (and (accept-char #:) (accept-to-chars #! #\space))) - (accept-user () - (and (accept-char #!) (accept-to-chars #@ #\space))) - (accept-host () - (and (accept-char #@) (accept-to-chars #\space))) - (accept-command () - (or (and (accept-char #\space) (accept-to-chars #\space)) - (accept-to-chars #\space))) - (accept-arguments () - (tokenize-string (or (accept-to-chars #:) (subseq raw-message-string index)) - :delimiters " ")) - (accept-trailing-argument () - ;; A line in the IRC Protocol ends in CRLF => - ;; Unix READ-LINE reads until a Linefeed occurs: "...CR"LF - ;; Win32 READ-LINE reads until a CR followed by a Linefeed occurs: "..."CRLF - ;; MacOS READ-LINE reads until a Carriage Return occurs: "..."CRLF - (and (accept-char #:) - #+unix (accept-to-chars #\Return) - #-unix (subseq raw-message-string index))) - (irc-message (&aux source user host command arguments trailing-argument) - (if (and (or (and (setf source (accept-source)) - (setf user (accept-user)) - (setf host (accept-host))) - t) - (setf command (accept-command)) - (or (setf arguments (accept-arguments)) t) - (or (setf trailing-argument (accept-trailing-argument)) t)) - (values source user host command arguments trailing-argument) - (error "IRC Message parse error - source: ~A - user: ~A - host: ~A - command: ~A - arguments: ~A - trailing-argument: ~A~%" source user host command arguments trailing-argument)))) - (irc-message))))) - -(defun parse-irc-message (raw-message-string) - (multiple-value-bind (source user host command arguments trailing-argument) - (parse-irc-message-1 raw-message-string) - (let ((ctcp (parse-ctcp-message trailing-argument)) - (class (cond ((every #'digit-char-p command) - (case (char command 0) - ((#\4 #\5) (setf command (find-reply-name (parse-integer command))) - 'irc-error-reply) - (otherwise - (find-irc-message-class - (setf command (find-reply-name (parse-integer command))))))) - (t (find-irc-message-class - (setf command (intern (string-upcase command) - (find-package :keyword)))))))) - (let ((msg (make-instance class - :source source - :user user - :host host - :command command - :arguments arguments - :connection nil - :trailing-argument trailing-argument - :received-time (get-universal-time) - :raw-message-string raw-message-string))) - (when ctcp - #-cmu(change-class msg (find-ctcp-message-class ctcp) :ctcp-command ctcp) - #+cmu - (progn - (change-class msg (find-ctcp-message-class ctcp)) - (reinitialize-instance msg :ctcp-command ctcp))) - msg)))) +(defun return-source (string &key (start 0)) + (cut-between string #: '(#! #\Space) :start start)) + +(defun return-user (string &key (start 0)) + (cut-between string #! '(#@ #\Space) :start start)) + +(defun return-host (string &key (start 0)) + (cut-between string #@ '(#\Space) :start start)) + +(defun return-command (string &key (start 0)) + (if (eql (char string start) #\Space) + (cut-between string #\Space '(#\Space) :start start) + (cut-between string nil '(#\Space) :start start :cut-extra nil))) + +(defun return-arguments (string &key (start 0)) + (multiple-value-bind (end-position return-argument) + (cut-between string nil '(#:) :start start) + (values end-position (tokenize-string return-argument + :delimiters '(#\Space))))) + +(defun return-trailing-argument (string &key (start 0)) + (cut-between string #: '(#\Return) :start start)) + +(defun parse-raw-message (string &key (start 0)) + (let ((index start) + (returns nil)) + (dolist (function '(return-source + return-user + return-host + return-command + return-arguments + return-trailing-argument)) + (multiple-value-bind (return-index return-string) + (funcall function string :start index) + (setf index return-index) + (push return-string returns))) + (apply #'values (reverse returns)))) + +(defun irc-error-reply-p (string) + (unless (zerop (length string)) + (if (and (every #'digit-char-p string) + (member (char string 0) '(#\4 #\5))) + t + nil))) + +(defun numeric-reply-p (string) + (every #'digit-char-p string))

(defun ctcp-type-p (string type) "What type of CTCP message is this?" @@ -122,3 +86,38 @@ (#\U (ctcp-type-p string :userinfo)) (otherwise nil))))

+(defun create-irc-message (string) + (multiple-value-bind (source user host command arguments trailing-argument) + (parse-raw-message string) + (let ((class 'irc-message) + (ctcp (parse-ctcp-message trailing-argument))) + (when command + (cond + ((irc-error-reply-p command) + (progn + (setf command (find-reply-name (parse-integer command))) + (setf class 'irc-error-reply))) + ((numeric-reply-p command) + (progn + (setf command (find-reply-name (parse-integer command))) + (setf class (find-irc-message-class command)))) + (t + (progn + (setf command (intern (string-upcase command) + (find-package :keyword))) + (setf class (find-irc-message-class command)))))) + (when ctcp + (setf class (find-ctcp-message-class ctcp))) + (let ((instance (make-instance class + :source source + :user user + :host host + :command command + :arguments arguments + :connection nil + :trailing-argument trailing-argument + :received-time (get-universal-time) + :raw-message-string string))) + (when ctcp + (setf (ctcp-command instance) ctcp)) + instance))))

Index: net-nittin-irc/protocol.lisp diff -u net-nittin-irc/protocol.lisp:1.4 net-nittin-irc/protocol.lisp:1.5 --- net-nittin-irc/protocol.lisp:1.4 Mon Nov 3 15:57:52 2003 +++ net-nittin-irc/protocol.lisp Fri Nov 7 08:43:06 2003 @@ -1,4 +1,4 @@ -;;;; $Id: protocol.lisp,v 1.4 2003/11/03 20:57:52 eenge Exp $ +;;;; $Id: protocol.lisp,v 1.5 2003/11/07 13:43:06 eenge Exp $ ;;;; $Source: /project/net-nittin-irc/cvsroot/net-nittin-irc/protocol.lisp,v $

;;;; See LICENSE for licensing information. @@ -112,13 +112,13 @@

(defmethod read-irc-message ((connection connection)) "Read an IRC-message from the connection." - (let ((message (parse-irc-message + (let ((message (create-irc-message (read-line (server-stream connection) t)))) (setf (connection message) connection) message))

(defmethod send-irc-message ((connection connection) command - trailing-argument &rest arguments) + trailing-argument &rest arguments) (let ((raw-message (make-irc-message command :arguments arguments :trailing-argument trailing-argument))) @@ -128,6 +128,7 @@

(defmethod all-users ((connection connection)) (let ((user-list (dangling-users connection))) + (push (user connection) user-list) (dolist (channel (channels connection)) (maphash #'(lambda (key value) (declare (ignore key)) @@ -151,6 +152,63 @@ (setf (gethash class (hooks connection)) (delete hook (gethash class (hooks connection)))))

+(defmethod remove-hooks ((connection connection) class) + (setf (gethash class (hooks connection)) nil)) + +;; +;; DCC Connection +;; + +(defclass dcc-connection () + ((user + :initarg :user + :accessor user + :documentation "The user at the other end of this connection. The +user at this end can be reached via your normal connection object.") + (stream + :initarg :stream + :accessor stream) + (socket + :initarg :socket + :accessor socket + :documentation "The actual socket object for the connection +between the two users."))) + +(defmethod print-object ((object dcc-connection) stream) + "Print the object for the Lisp reader." + (print-unreadable-object (object stream :type t :identity t) + (if (user object) + (format stream "with ~A@~A" + (nickname (user object)) + (hostname (user object))) + + ""))) + +(defun make-dcc-connection (&key (user nil) + (socket nil) + (stream nil)) + (let ((connection (make-instance 'dcc-connection + :user user + :stream stream + :socket socket))) + connection)) + +(defmethod read-message ((connection dcc-connection)) + (read-line (stream connection))) + +(defmethod read-message-loop ((connection dcc-connection)) + (loop while (read-message connection))) + +(defmethod send-dcc-message ((connection dcc-connection) message) + (format (stream connection) "~A~%" message)) + +;; argh. I want to name this quit but that gives me issues with +;; generic functions. need to resolve. +(defmethod dcc-close ((connection dcc-connection)) + (close (stream connection)) + (setf (user connection) nil) + (sb-bsd-sockets:socket-close (socket connection))) + ;; ;; Channel ;; @@ -402,17 +460,6 @@

(defmethod find-ctcp-message-class (type) (find-class 'standard-ctcp-message)) - -(defmethod update-instance-for-different-class :before - ((previous irc-message) (current ctcp-mixin) - &rest initargs &key &allow-other-keys) - "Convert a general IRC-MESSAGE to a CTCP message." - (let* ((text (trailing-argument previous)) - (start (position #\space text))) - (setf (trailing-argument current) - (if (and start (< start (length text))) - (subseq text (1+ start) (position +soh+ text :from-end t)) - ""))))

(defmethod client-log ((connection connection) (message ctcp-mixin) &optional (prefix "")) (let ((stream (client-stream connection)))

Index: net-nittin-irc/utility.lisp diff -u net-nittin-irc/utility.lisp:1.1.1.1 net-nittin-irc/utility.lisp:1.2 --- net-nittin-irc/utility.lisp:1.1.1.1 Mon Nov 3 12:00:54 2003 +++ net-nittin-irc/utility.lisp Fri Nov 7 08:43:06 2003 @@ -1,4 +1,4 @@ -;;;; $Id: utility.lisp,v 1.1.1.1 2003/11/03 17:00:54 eenge Exp $ +;;;; $Id: utility.lisp,v 1.2 2003/11/07 13:43:06 eenge Exp $ ;;;; $Source: /project/net-nittin-irc/cvsroot/net-nittin-irc/utility.lisp,v $

;;;; See the LICENSE file for licensing information. @@ -79,25 +79,54 @@ (format nil "~A~A~A" +soh+ message +soh+))

(defun tokenize-string (string &key - (delimiters '(#\Space #\Return #\Linefeed #\Newline)) - (test (lambda (c) (find c delimiters))) - (start 0) - (end (length string)) - (omit-delimiters t)) - (flet ((get-token (start) - (if (< start end) - (let* ((delimiterp (funcall test (char string start))) - (end-of-token (funcall (if delimiterp - #'position-if-not - #'position-if) - test string :start start))) - (values (subseq string start end-of-token) end-of-token delimiterp)) - (values nil nil nil)))) - (let ((tokens nil) - token delimiterp) - (loop (multiple-value-setq (token start delimiterp) (get-token start)) - (unless (and delimiterp omit-delimiters) - (push token tokens)) - (unless start - (return-from tokenize-string (nreverse tokens))))))) - + (delimiters '(#\Space #\Return #\Linefeed #\Newline))) + "Split string into a list, splitting on delimiters and removing any +empty subsequences." + (split-sequence:split-sequence-if #'(lambda (character) + (member character delimiters)) + string :remove-empty-subseqs t)) + +(defun list-of-strings-to-integers (list) + "Take a list of strings and return a new list of integers (from +parse-integer) on each of the string elements." + (let ((new-list nil)) + (dolist (element (reverse list)) + (push (parse-integer element) new-list)) + new-list)) + +(defun host-byte-order (string) + "Convert a string, such as 192.168.1.1, to host-byte-order, such as +3232235777." + (let ((list (list-of-strings-to-integers (split-sequence:split-sequence #. string)))) + (+ (* (first list) 256 256 256) (* (second list) 256 256) + (* (third list) 256) (fourth list)))) + +(defun hbo-to-dotted-quad (integer) + "Host-byte-order integer to dotted-quad string conversion utility." + (let ((first (ldb (byte 8 24) integer)) + (second (ldb (byte 8 16) integer)) + (third (ldb (byte 8 8) integer)) + (fourth (ldb (byte 8 0) integer))) + (format nil "~A.~A.~A.~A" first second third fourth))) + +(defun cut-between (string start-char end-chars &key (start 0) (cut-extra t)) + "If start-char is not nil, cut string between start-char and any of +the end-chars, from start. If start-char is nil, cut from start until +any of the end-chars. + +If cut-extra is t, we will cut from start + 1 instead of just start." + (let ((end-position (position-if #'(lambda (char) + (member char end-chars)) + string :start (1+ start))) + (cut-from (if cut-extra + (1+ start) + start))) + (if (and end-position start-char) + (if (eql (char string start) start-char) + (values end-position + (subseq string cut-from end-position)) + (values start nil)) + (if end-position + (values end-position + (subseq string cut-from end-position)) + (values start nil)))))

Index: net-nittin-irc/variable.lisp diff -u net-nittin-irc/variable.lisp:1.2 net-nittin-irc/variable.lisp:1.3 --- net-nittin-irc/variable.lisp:1.2 Mon Nov 3 12:11:17 2003 +++ net-nittin-irc/variable.lisp Fri Nov 7 08:43:06 2003 @@ -1,4 +1,4 @@ -;;;; $Id: variable.lisp,v 1.2 2003/11/03 17:11:17 eenge Exp $ +;;;; $Id: variable.lisp,v 1.3 2003/11/07 13:43:06 eenge Exp $ ;;;; $Source: /project/net-nittin-irc/cvsroot/net-nittin-irc/variable.lisp,v $

;;;; See the LICENSE file for licensing information. @@ -25,8 +25,6 @@ (defvar *default-irc-server-port* 6667) (defvar *default-quit-message* "Common Lisp IRC library - http://common-lisp.net/project/net-nittin-irc") - -(defvar *event-hooks* nil)

(defparameter *reply-names* '((1 :rpl_welcome)