[net-nittin-irc-cvs] CVS update: net-nittin-irc/command.lisp net-nittin-irc/event.lisp net-nittin-irc/net-nittin-irc.asd net-nittin-irc/package.lisp net-nittin-irc/parse-message.lisp net-nittin-irc/protocol.lisp net-nittin-irc/utility.lisp net-nittin-irc/variable.lisp
Erik Enge
eenge at common-lisp.net
Fri Nov 7 13:43:08 UTC 2003
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)
More information about the Net-nittin-irc-cvs
mailing list