cl-irc-cvs

cl-irc-cvs@common-lisp.net

220 discussions

[cl-irc-cvs] r201 - trunk
by ehuelsmann＠common-lisp.net 25 Apr '07

25 Apr '07

Author: ehuelsmann Date: Tue Apr 24 18:28:02 2007 New Revision: 201 Modified: trunk/package.lisp trunk/parse-message.lisp trunk/protocol.lisp Log: Implement CTCP-over-DCC framework. Modified: trunk/package.lisp ============================================================================== --- trunk/package.lisp (original) +++ trunk/package.lisp Tue Apr 24 18:28:02 2007 @@ -146,6 +146,7 @@ :close-on-main :remote-user :dcc-close + :dcc-message :dcc-message-event :make-dcc-chat-connection ))) Modified: trunk/parse-message.lisp ============================================================================== --- trunk/parse-message.lisp (original) +++ trunk/parse-message.lisp Tue Apr 24 18:28:02 2007 @@ -226,13 +226,13 @@ (defun create-dcc-message (string) (let* ((class 'dcc-privmsg-message) (ctcp (ctcp-message-type string))) -;; (when ctcp -;; (setf class (find-dcc-ctcp-message class ctcp))) + (when ctcp + (setf class (find-dcc-ctcp-message class ctcp))) (let ((instance (make-instance class :arguments (list string) :connection nil :received-time (get-universal-time) :raw-message-string string))) -;; (when ctcp -;; (setf (ctcp-command instance) ctcp)) + (when ctcp + (setf (ctcp-command instance) ctcp)) instance))) Modified: trunk/protocol.lisp ============================================================================== --- trunk/protocol.lisp (original) +++ trunk/protocol.lisp Tue Apr 24 18:28:02 2007 @@ -1117,12 +1117,21 @@ :accessor ctcp-command))) (defclass standard-ctcp-message (ctcp-mixin irc-message) ()) +(defclass standard-dcc-ctcp-message (ctcp-mixin dcc-message) ()) (defgeneric find-ctcp-message-class (type)) +(defgeneric find-dcc-ctcp-message-class (type)) (defgeneric ctcp-request-p (message)) (defgeneric ctcp-reply-p (message)) (eval-when (:compile-toplevel :load-toplevel :execute) + (defun define-dcc-ctcp-message (ctcp-command) + (let ((name (intern-message-symbol :dcc-ctcp ctcp-command))) + `(progn + (defmethod find-dcc-ctcp-message-class ((type (eql ,ctcp-command))) + (find-class ',name)) + (export ',name) + (defclass ,name (ctcp-mixin dcc-message) ())))) (defun define-ctcp-message (ctcp-command) (let ((name (intern-message-symbol :ctcp ctcp-command))) `(progn @@ -1132,7 +1141,8 @@ (defclass ,name (ctcp-mixin irc-message) ()))))) (defmacro create-ctcp-message-classes (class-list) - `(progn ,@(mapcar #'define-ctcp-message class-list))) + `(progn ,@(mapcar #'define-ctcp-message class-list) + ,@(mapcar #'define-dcc-ctcp-message class-list))) ;; should perhaps wrap this in an eval-when? (create-ctcp-message-classes (:action :source :finger :ping @@ -1143,6 +1153,10 @@ (declare (ignore type)) (find-class 'standard-ctcp-message)) +(defmethod find-dcc-ctcp-message-class (type) + (declare (ignore type)) + (find-class 'standard-dcc-ctcp-message)) + (defmethod ctcp-request-p ((message ctcp-mixin)) (string= (command message) :privmsg))

1 0

[cl-irc-cvs] r200 - trunk
by ehuelsmann＠common-lisp.net 25 Apr '07

25 Apr '07

Author: ehuelsmann Date: Tue Apr 24 18:23:39 2007 New Revision: 200 Modified: trunk/event.lisp trunk/package.lisp Log: r199 followup: read-message calls dcc-message-event. Provide it. Modified: trunk/event.lisp ============================================================================== --- trunk/event.lisp (original) +++ trunk/event.lisp Tue Apr 24 18:23:39 2007 @@ -15,6 +15,16 @@ (unless (apply-to-hooks message) (client-log (connection message) message "UNHANDLED-EVENT:"))) +(defgeneric dcc-message-event (connection message) + (:documentation "Upon receipt of an IRC message from the +connection's stream, irc-message-event will be called with the +message.")) + +(defmethod dcc-message-event (connection (message dcc-message)) + (declare (ignore connection)) + (unless (apply-to-hooks message) + (client-log (connection message) message "UNHANDLED-EVENT:"))) + (defgeneric default-hook (message) (:documentation "Minimum action to be executed upon reception Modified: trunk/package.lisp ============================================================================== --- trunk/package.lisp (original) +++ trunk/package.lisp Tue Apr 24 18:23:39 2007 @@ -146,6 +146,7 @@ :close-on-main :remote-user :dcc-close + :dcc-message-event :make-dcc-chat-connection )))

1 0

[cl-irc-cvs] r199 - trunk
by ehuelsmann＠common-lisp.net 25 Apr '07

25 Apr '07

Author: ehuelsmann Date: Tue Apr 24 18:15:07 2007 New Revision: 199 Modified: trunk/package.lisp trunk/protocol.lisp Log: Add a dcc-chat-connection class; a non-abstract subclass of dcc-connection. Modified: trunk/package.lisp ============================================================================== --- trunk/package.lisp (original) +++ trunk/package.lisp Tue Apr 24 18:15:07 2007 @@ -141,9 +141,11 @@ :ison ;; DCC specific dictionary :dcc-connection + :dcc-chat-connection :irc-connection :close-on-main :remote-user :dcc-close + :make-dcc-chat-connection ))) Modified: trunk/protocol.lisp ============================================================================== --- trunk/protocol.lisp (original) +++ trunk/protocol.lisp Tue Apr 24 18:15:07 2007 @@ -335,7 +335,8 @@ #+openmcl (ccl:process-kill process) #+armedbear (ext:destroy-thread process)) -(defun read-message-loop (connection) +(defgeneric read-message-loop (connection)) +(defmethod read-message-loop (connection) (loop while (read-message connection))) @@ -360,11 +361,13 @@ (force-output (output-stream connection)) raw-message)) -(defmethod get-hooks ((connection connection) (class symbol)) +;;applies to both irc and dcc-connections +(defmethod get-hooks (connection (class symbol)) "Return a list of all hooks for `class'." (gethash class (hooks connection))) -(defmethod add-hook ((connection connection) class hook) +;;applies to both irc and dcc-connections +(defmethod add-hook (connection class hook) "Add `hook' to `class'." (setf (gethash class (hooks connection)) (pushnew hook (gethash class (hooks connection))))) @@ -479,6 +482,9 @@ ;; CHAT related generic functions (defgeneric send-dcc-message (connection message)) +;;already defined in relation to `connection' +;; (defgeneric read-message (connection)) +;;(defgeneric dcc-message-event (message)) <defined in event.lisp> ;; SEND related generic functions ;;<none yet, we don't do SEND yet...> @@ -487,6 +493,10 @@ (and (streamp stream) (open-stream-p stream)))) +(defmethod send-dcc-message ((connection dcc-connection) message) + (format (output-stream connection) "~A~%" message) + (force-output (network-stream connection))) + (defmethod dcc-close ((connection dcc-connection)) #+(and sbcl (not sb-thread)) (sb-sys:invalidate-descriptor @@ -498,6 +508,68 @@ (dcc-connections (irc-connection connection)) (remove connection (dcc-connections (irc-connection connection))))) + +(defclass dcc-chat-connection (dcc-connection) + ((output-stream + :initarg :output-stream + :initform nil + :accessor output-stream + :documentation "Stream used to communicate with the other end +of the network pipe.") + (hooks + :initform (make-hash-table :test #'equal) + :accessor hooks)) + (:documentation "")) + + +(defun make-dcc-chat-connection (&key (remote-user nil) +;; (remote-address nil) +;; (remote-port nil) + (client-stream nil) + (irc-connection nil) + (close-on-main t) + (socket nil) + (network-stream nil) + (outgoing-external-format *default-outgoing-external-format*) + (hooks nil)) + (let* ((output-stream (flexi-streams:make-flexi-stream + network-stream + :element-type 'character + :external-format (external-format-fixup + outgoing-external-format))) + (connection (make-instance 'dcc-chat-connection + :remote-user remote-user + :client-stream client-stream + :output-stream output-stream + :irc-connection irc-connection + :close-on-main close-on-main + :socket socket + :network-stream network-stream))) + (dolist (hook hooks) + (add-hook connection (car hook) (cdar hook))) + connection)) + +(defmethod read-message ((connection dcc-chat-connection)) + (when (connectedp connection) + (let* ((msg-string (read-protocol-line connection)) + (message (create-dcc-message msg-string))) + (setf (connection message) connection) + (when *debug-p* + (format *debug-stream* "~A" (describe message)) + (force-output *debug-stream*)) + (dcc-message-event connection message) + message))) ; needed because of the "loop while" in read-message-loop + +(defmethod read-message-loop ((connection dcc-chat-connection)) + ;; no special setup + (call-next-method) + ;; now, make sure the connection was closed and cleaned up properly... + ;; it *was* the last message, after all... + ;;##TODO, maybe we need some kind of 'auto-clean' slot to indicate + ;; this is the desired behaviour? + ) + + ;; ;; Channel ;; @@ -968,8 +1040,8 @@ (car (last (arguments message)))) (force-output stream))) - -(defmethod apply-to-hooks ((message irc-message)) +;; applies to both irc- and dcc-messages +(defmethod apply-to-hooks (message) "Applies any applicable hooks to `message'. Returns non-nil if any of the hooks do."

1 0

[cl-irc-cvs] r198 - trunk
by ehuelsmann＠common-lisp.net 25 Apr '07

25 Apr '07

Author: ehuelsmann Date: Tue Apr 24 18:02:47 2007 New Revision: 198 Modified: trunk/parse-message.lisp Log: r197 followup: disable (yet) unimplemented part (ctcp messages). Modified: trunk/parse-message.lisp ============================================================================== --- trunk/parse-message.lisp (original) +++ trunk/parse-message.lisp Tue Apr 24 18:02:47 2007 @@ -226,13 +226,13 @@ (defun create-dcc-message (string) (let* ((class 'dcc-privmsg-message) (ctcp (ctcp-message-type string))) - (when ctcp - (setf class (find-dcc-ctcp-message class ctcp))) +;; (when ctcp +;; (setf class (find-dcc-ctcp-message class ctcp))) (let ((instance (make-instance class :arguments (list string) :connection nil :received-time (get-universal-time) :raw-message-string string))) - (when ctcp - (setf (ctcp-command instance) ctcp)) +;; (when ctcp +;; (setf (ctcp-command instance) ctcp)) instance)))

1 0

[cl-irc-cvs] r197 - trunk
by ehuelsmann＠common-lisp.net 25 Apr '07

25 Apr '07

Author: ehuelsmann Date: Tue Apr 24 18:01:01 2007 New Revision: 197 Modified: trunk/parse-message.lisp trunk/protocol.lisp Log: Create a DCC CHAT message class, just like the IRC message classes we have. Modified: trunk/parse-message.lisp ============================================================================== --- trunk/parse-message.lisp (original) +++ trunk/parse-message.lisp Tue Apr 24 18:01:01 2007 @@ -222,3 +222,17 @@ (when ctcp (setf (ctcp-command instance) ctcp)) instance)))) + +(defun create-dcc-message (string) + (let* ((class 'dcc-privmsg-message) + (ctcp (ctcp-message-type string))) + (when ctcp + (setf class (find-dcc-ctcp-message class ctcp))) + (let ((instance (make-instance class + :arguments (list string) + :connection nil + :received-time (get-universal-time) + :raw-message-string string))) + (when ctcp + (setf (ctcp-command instance) ctcp)) + instance))) Modified: trunk/protocol.lisp ============================================================================== --- trunk/protocol.lisp (original) +++ trunk/protocol.lisp Tue Apr 24 18:01:01 2007 @@ -981,6 +981,61 @@ result))))) ;; +;; DCC CHAT messages +;; + +(defclass dcc-message () + ((connection + :initarg :connection + :accessor connection + :documentation "") + (arguments + :initarg :arguments + :accessor arguments + :type list + :documentation "") + (received-time + :initarg :received-time + :accessor received-time) + (raw-message-string + :initarg :raw-message-string + :accessor raw-message-string + :type sting)) + (:documentation "")) + +(defmethod print-object ((object dcc-message) stream) + "Print the object for the Lisp reader." + (print-unreadable-object (object stream :type t :identity t) + (format stream "~A ~A" + (nickname (remote-user (connection object))) + (command object)))) + +(defgeneric find-dcc-message-class (type)) +;;already defined in the context of IRC messages: +;; (defgeneric client-log (connection message &optional prefix)) +;; (defgeneric apply-to-hooks (message)) + + +(export 'dcc-privmsg-message) +(defclass dcc-privmsg-message (dcc-message) ()) +(defmethod find-dcc-message-class ((type (eql :privmsg))) + (find-class 'dcc-privmsg-message)) + +(defmethod find-dcc-message-class (type) + (declare (ignore type)) + (find-class 'dcc-message)) + +(defmethod client-log ((connection dcc-connection) + (message dcc-message) &optional (prefix "")) + (let ((stream (client-stream connection))) + (format stream "~A~A: ~{ ~A~} \"~A\"~%" + prefix + (received-time message) + (butlast (arguments message)) + (car (last (arguments message)))) + (force-output stream))) + +;; ;; CTCP Message ;;

1 0

[cl-irc-cvs] r196 - trunk
by ehuelsmann＠common-lisp.net 24 Apr '07

24 Apr '07

Author: ehuelsmann Date: Tue Apr 24 17:51:56 2007 New Revision: 196 Modified: trunk/protocol.lisp Log: Move connectedp into the dcc-connection section; ignore errors when closing a connection. Modified: trunk/protocol.lisp ============================================================================== --- trunk/protocol.lisp (original) +++ trunk/protocol.lisp Tue Apr 24 17:51:56 2007 @@ -482,23 +482,22 @@ ;; SEND related generic functions ;;<none yet, we don't do SEND yet...> - +(defmethod connectedp ((connection dcc-connection)) + (let ((stream (network-stream connection))) + (and (streamp stream) + (open-stream-p stream)))) (defmethod dcc-close ((connection dcc-connection)) #+(and sbcl (not sb-thread)) (sb-sys:invalidate-descriptor (sb-sys:fd-stream-fd (network-stream connection))) - (close (network-stream connection)) + (ignore-errors + (close (network-stream connection))) (setf (remote-user connection) nil *dcc-connections* (remove connection *dcc-connections*) (dcc-connections (irc-connection connection)) (remove connection (dcc-connections (irc-connection connection))))) -(defmethod connectedp ((connection dcc-connection)) - (let ((stream (network-stream connection))) - (and (streamp stream) - (open-stream-p stream)))) - ;; ;; Channel ;;

1 0

[cl-irc-cvs] r195 - trunk
by ehuelsmann＠common-lisp.net 24 Apr '07

24 Apr '07

Author: ehuelsmann Date: Tue Apr 24 16:27:35 2007 New Revision: 195 Modified: trunk/protocol.lisp Log: r193 followup: 'user' was renamed to 'remote-user' to disambiguate its meaning. Modified: trunk/protocol.lisp ============================================================================== --- trunk/protocol.lisp (original) +++ trunk/protocol.lisp Tue Apr 24 16:27:35 2007 @@ -462,10 +462,10 @@ (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) + (if (remote-user object) (format stream "with ~A@~A" - (nickname (user object)) - (hostname (user object))) + (nickname (remote-user object)) + (hostname (remote-user object))) "")))

1 0

[cl-irc-cvs] r194 - trunk
by ehuelsmann＠common-lisp.net 24 Apr '07

24 Apr '07

Author: ehuelsmann Date: Tue Apr 24 16:24:26 2007 New Revision: 194 Modified: trunk/protocol.lisp Log: Define fallback functions for the case where the message passed isn't even a subtype of ctcp-mixin. Modified: trunk/protocol.lisp ============================================================================== --- trunk/protocol.lisp (original) +++ trunk/protocol.lisp Tue Apr 24 16:24:26 2007 @@ -1020,9 +1020,21 @@ (defmethod ctcp-request-p ((message ctcp-mixin)) (string= (command message) :privmsg)) +(defmethod ctcp-request-p (message) + ;; If we're not calling the above method, then, obviously + ;; this was never a ctcp-thing to start with + (declare (ignore message)) + nil) + (defmethod ctcp-reply-p ((message ctcp-mixin)) (string= (command message) :notice)) +(defmethod ctcp-reply-p (message) + (declare (ignore message)) + ;; If we're not calling the above method, then, obviously + ;; this was never a ctcp-thing to start with + nil) + (defmethod client-log ((connection connection) (message ctcp-mixin) &optional (prefix "")) (let ((stream (client-stream connection))) (format stream "~A~A: ~A (~A): ~A~{ ~A~} \"~A\"~%"

1 0

[cl-irc-cvs] r193 - trunk
by ehuelsmann＠common-lisp.net 24 Apr '07

24 Apr '07

Author: ehuelsmann Date: Tue Apr 24 16:16:50 2007 New Revision: 193 Modified: trunk/package.lisp trunk/protocol.lisp Log: Rearrange code. Make dcc-connection an abstract base class. Modified: trunk/package.lisp ============================================================================== --- trunk/package.lisp (original) +++ trunk/package.lisp Tue Apr 24 16:16:50 2007 @@ -138,5 +138,12 @@ :users- :wallops :userhost - :ison))) + :ison + ;; DCC specific dictionary + :dcc-connection + :irc-connection + :close-on-main + :remote-user + :dcc-close + ))) Modified: trunk/protocol.lisp ============================================================================== --- trunk/protocol.lisp (original) +++ trunk/protocol.lisp Tue Apr 24 16:16:50 2007 @@ -144,6 +144,10 @@ :initform t :documentation "Messages coming back from the server are sent to this stream.") + (dcc-connections + :accessor dcc-connections + :initform '() + :documentation "The DCC connections associated with this IRC connection.") (channels :initarg :channels :accessor channels @@ -417,18 +421,43 @@ ;; (defclass dcc-connection () - ((user - :initarg :user - :accessor user + ((irc-connection + :initarg :irc-connection + :accessor irc-connection + :initform nil + :documentation "The associated IRC connection used to send +CTCP control commands. When this connection is closed/lost, +the DCC connection should be terminated too for security reasons.") + (close-on-main + :initarg :close-on-main + :accessor close-on-main + :initform t + :documentation "Makes sure that the DCC connection is closed +as soon as either the IRC connection is actively closed or when +a lost connection is detected.") + (remote-user + :initarg :remote-user + :accessor remote-user :documentation "The user at the other end of this connection. The user at this end can be reached via your normal connection object.") + (socket + :initarg :socket + :accessor socket + :initform nil + :documentation "Socket used to do the remote client.") (network-stream :initarg :network-stream :accessor network-stream) - (output-stream - :initarg :output-stream - :accessor output-stream - :initform t))) + (client-stream + :initarg :client-stream + :accessor client-stream + :documentation "Input from the remote is sent to this stream.")) + (:documentation "Abstract superclass of all types of DCC connections. + +This class isn't meant to be instanciated. The different DCC subprotocols +differ widely in the way they transmit their data, meaning there are +relatively few methods which can be defined for this class. They do +share a number of properties though.")) (defmethod print-object ((object dcc-connection) stream) "Print the object for the Lisp reader." @@ -439,43 +468,31 @@ (hostname (user object))) ""))) -(defun make-dcc-connection (&key (user nil) - (remote-address nil) - (remote-port nil) - (output-stream t)) - (make-instance 'dcc-connection - :user user - :network-stream (usocket:socket-connect remote-address - remote-port) - :output-stream output-stream)) +;; Common generic functions + +;; argh. I want to name this quit but that gives me issues with +;; generic functions. need to resolve. (defgeneric dcc-close (connection)) +;;already defined in relation to `connection': +;; (defgeneric connectedp (connection)) + +;; CHAT related generic functions (defgeneric send-dcc-message (connection message)) -(defmethod read-message ((connection dcc-connection)) - (when (connectedp connection) - (let ((message (read-line (network-stream connection)))) - (format (output-stream connection) "~A~%" message) - (force-output (output-stream connection)) - (when *debug-p* - (format *debug-stream* "~A" (describe message))) - ;; (dcc-message-event message) - message))) ; needed because of the "loop while" in read-message-loop +;; SEND related generic functions +;;<none yet, we don't do SEND yet...> -(defmethod send-dcc-message ((connection dcc-connection) message) - (format (network-stream connection) "~A~%" message) - (force-output (network-stream connection))) -;; argh. I want to name this quit but that gives me issues with -;; generic functions. need to resolve. (defmethod dcc-close ((connection dcc-connection)) #+(and sbcl (not sb-thread)) (sb-sys:invalidate-descriptor (sb-sys:fd-stream-fd (network-stream connection))) (close (network-stream connection)) - (setf (user connection) nil) - (setf *dcc-connections* (remove connection *dcc-connections*)) - ) + (setf (remote-user connection) nil + *dcc-connections* (remove connection *dcc-connections*) + (dcc-connections (irc-connection connection)) + (remove connection (dcc-connections (irc-connection connection))))) (defmethod connectedp ((connection dcc-connection)) (let ((stream (network-stream connection)))

1 0

[cl-irc-cvs] r192 - trunk
by ehuelsmann＠common-lisp.net 23 Apr '07

23 Apr '07

Author: ehuelsmann Date: Mon Apr 23 02:47:15 2007 New Revision: 192 Modified: trunk/parse-message.lisp Log: Rename shadowing local binding (type -> sess-type). Modified: trunk/parse-message.lisp ============================================================================== --- trunk/parse-message.lisp (original) +++ trunk/parse-message.lisp Mon Apr 23 02:47:15 2007 @@ -123,38 +123,38 @@ "Is the `string' actually a representation of the DCC `type'?" (let* ((args (tokenize-string (string-trim (list +soh+) string))) (dcc (string-upcase (first args))) - (type (string-upcase (second args)))) + (sess-type (string-upcase (second args)))) (when (string= dcc "DCC") (let ((r ;; the list below was found on Wikipedia and in kvirc docs - (second (assoc type '(("CHAT" :dcc-chat-request) - ("SEND" :dcc-send-request) - ("XMIT" :dcc-xmit-request) - ("SCHAT" :dcc-schat-request) - ("SSEND" :dcc-ssend-request) - ("REVERSE" :dcc-reverse-request) - ("RSEND" :dcc-rsend-request) - ("TSEND" :dcc-tsend-request) - ("STSEND" :dcc-stsend-request) - ("TSSEND" :dcc-stsend-request) - ("RESUME" :dcc-resume-request) - ("ACCEPT" :dcc-accept-request) - ;; GET - ;; TGET - ;; STGET - ;; TSGET - ;; RECV - ;; SRECV - ;; TRECV - ;; STRECV - ;; TSRECV - ;; RSEND - ;; SRSEND - ;; TRSEND - ;; STRSEND - ;; TSRSEND - ;; VOICE - ) :test #'string=)))) + (second (assoc sess-type '(("CHAT" :dcc-chat-request) + ("SEND" :dcc-send-request) + ("XMIT" :dcc-xmit-request) + ("SCHAT" :dcc-schat-request) + ("SSEND" :dcc-ssend-request) + ("REVERSE" :dcc-reverse-request) + ("RSEND" :dcc-rsend-request) + ("TSEND" :dcc-tsend-request) + ("STSEND" :dcc-stsend-request) + ("TSSEND" :dcc-stsend-request) + ("RESUME" :dcc-resume-request) + ("ACCEPT" :dcc-accept-request) + ;; GET + ;; TGET + ;; STGET + ;; TSGET + ;; RECV + ;; SRECV + ;; TRECV + ;; STRECV + ;; TSRECV + ;; RSEND + ;; SRSEND + ;; TRSEND + ;; STRSEND + ;; TSRSEND + ;; VOICE + ) :test #'string=)))) (when (eq r type) type)))))

1 0

← Newer
1
2
3
4
5
6
7
8
...
22
Older →

Jump to page:

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

2005

2004

cl-irc-cvs