Author: ehuelsmann Date: Mon Apr 30 03:56:05 2007 New Revision: 204
Modified: trunk/command.lisp trunk/event.lisp trunk/package.lisp trunk/protocol.lisp Log: DCC implementation checkpoint: Working DCC CHAT with passive local side. 'passive local' == either remote initiates or local passive initiative.
Modified: trunk/command.lisp ============================================================================== --- trunk/command.lisp (original) +++ trunk/command.lisp Mon Apr 30 03:56:05 2007 @@ -59,7 +59,19 @@ (defgeneric ison (connection user)) (defgeneric ctcp (connection target message)) (defgeneric ctcp-reply (connection target message)) -(defgeneric ctcp-chat-initiate (connection nickname)) +(defgeneric ctcp-chat-initiate (connection nickname &key passive) + (:documentation "Initiate a DCC chat session with `nickname' associated +with `connection'. + +If `passive' is non-NIL, the remote is requested to serve as a DCC +host. Otherwise, the local system will serve as a DCC host. The +latter may be a problem for firewalled or NATted hosts.")) +(defgeneric dcc-request-accept (message) + (:documentation "")) +(defgeneric dcc-request-reject (message &optional reason) + (:documentation "")) +(defgeneric dcc-request-cancel (connection token) + (:documentation ""))
(defmethod pass ((connection connection) (password string)) @@ -138,6 +150,9 @@ (defmethod quit ((connection connection) &optional (message *default-quit-message*)) (remove-all-channels connection) (remove-all-users connection) + (dolist (dcc (dcc-connections connection)) + (when (close-on-main dcc) + (quit dcc "Main IRC server connection lost."))) (unwind-protect (send-irc-message connection :quit message) #+(and sbcl (not sb-thread)) @@ -368,23 +383,174 @@ (defmethod ctcp-reply ((connection connection) target message) (send-irc-message connection :notice target (make-ctcp-message message)))
-#| -There's too much wrong with this method to fix it now.
-(defmethod ctcp-chat-initiate ((connection connection) (nickname string)) - #+sbcl - (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)) - #-sbcl (warn "ctcp-chat-initiate is not supported on this implementation.") - ) +;; Intermezzo: Manage outstanding offers + +(defvar *passive-offer-sequence-token* 0) + +(defgeneric dcc-add-offer (connection nickname type token &optional proto) + (:documentation "Adds an offer to the list off outstanding offers list +for `connection'.")) + +(defgeneric dcc-remove-offer (connection token) + ;; Tokens are uniquely defined within the scope of the library, + ;; so we don't need anything but the token to actually remove an offer + (:documentation "Remove an offer from the list of outstanding offers +for `connection'.")) + +(defgeneric dcc-get-offer (connection token)) +(defgeneric dcc-get-offers (connection nickname &key type token)) + +(defun matches-offer-by-token-p (offer token) + (equal (third offer) token)) + +(defun matches-offer-by-user-p (offer user) + (equal (first offer) user)) + +(defun offer-matches-message-p (offer message-nick message-type message-token) + (and (equal (first offer) message-nick) + (equal (second offer) message-type) + (equal (third offer) message-token))) + +(defmethod dcc-add-offer (connection nickname type token &optional proto) + (push (list nickname type token) (dcc-offers connection))) + +(defmethod dcc-remove-offer (connection token) + (setf (dcc-offers connection) + (remove-if #'(lambda (x) + (matches-offer-by-token-p x token)) + (dcc-offers connection)))) + +(defmethod dcc-get-offer (connection token) + (let ((offer-list (remove-if #'(lambda (x) + (not (equal (third x) token))) + (dcc-offers connection)))) + (first offer-list))) + +(defmethod dcc-get-offers (connection nickname &key type token) + (let* ((results (remove-if #'(lambda (x) + (not (matches-offer-by-user-p x nickname))) + (dcc-offers connection))) + (results (if type + (remove-if #'(lambda (x) + (not (equal type (second x)))) results) + results)) + (results (if token + (remove-if #'(lambda (x) + (not (equal token (third x)))) results)))) + results)) + +;; End of intermezzo + +;; +;; And we move on with the definitions required to manage the protocol +;; + +(defmethod ctcp-chat-initiate ((connection connection) (nickname string) + &key passive) + (if passive + ;; do passive request + (let ((token (princ-to-string (incf *passive-offer-sequence-token*)))) + ;; tokens have been specified to be integer values, + (dcc-add-offer connection nickname "CHAT" token) + (ctcp connection nickname + (format nil "DCC CHAT CHAT ~A 0 ~A" + (usocket:host-byte-order #(1 1 1 1)) + token)) + token) + ;; or do active request + (error "Active DCC initiating not (yet) supported."))) + +(defmethod dcc-request-cancel (connection token) + (dcc-remove-offer connection token) + (if (stringp token) + (let ((offer (dcc-offer-get connection token))) + ;; We have a passive request; active ones have an associated + ;; socket instead... + (ctcp-reply connection (first offer) + (format nil "DCC REJECT ~A ~A" (second offer) token))) + (progn + ;; do something to close the socket here... + ;; OTOH, we don't support active sockets (yet), so, comment out. +#| + (usocket:socket-close token) + (ctcp-reply connection nickname (format nil + "ERRMSG DCC ~A timed out" type)) |# + ))) + +(defmethod dcc-request-accept ((message ctcp-dcc-chat-request-message)) + ;; There are 2 options here: it was an active dcc offer or a passive one + ;; For now, we'll support only active offers (where we act as a client) + (let* ((raw-offer (car (last (arguments message)))) + (clean-offer (string-trim (list +soh+) raw-offer)) + (args (tokenize-string clean-offer)) + (remote-ip (ignore-errors (parse-integer (fourth args)))) + (remote-port (ignore-errors (parse-integer (fifth args)))) + (their-token (sixth args)) + (irc-connection (connection message))) + (when (string= (string-upcase (third args)) "CHAT") + (if (= remote-port 0) + ;; a passive chat request, which we don't support (yet): + ;; we don't act as a server yet + (ctcp-reply irc-connection (source message) + "ERRMSG DCC CHAT passive-CHAT unavailable") + (progn + (when their-token + (let ((offer (dcc-get-offer irc-connection their-token))) + (when (or (null offer) + (not (offer-matches-message-p offer + (source message) + "CHAT" their-token))) + (ctcp-reply irc-connection (source message) + (format nil + "ERRMSG DCC CHAT invalid token (~A)" + their-token)) + (return-from dcc-request-accept)))) + ;; ok, so either there was no token, or it matches + ;; + ;; When there was no token, but there was a chat request + ;; with the same nick and type, maybe we achieved the same + ;; in the end. (This would be caused by the other side + ;; initiating the request manually after the client blocked + ;; and automatic response. + (let ((offers (dcc-get-offers irc-connection (source message) + :type "CHAT"))) + (when offers + ;; if there are more offers, consider the first fulfilled. + (dcc-remove-offer irc-connection (third (first offers))))) + + (let ((socket (unless (or (null remote-ip) + (null remote-port) + (= 0 remote-port)) + (usocket:socket-connect + remote-ip remote-port + :element-type 'flexi-streams:octet)))) + (dcc-remove-offer irc-connection their-token) + (make-dcc-chat-connection + :irc-connection irc-connection + :remote-user (find-user irc-connection (source message)) + :socket socket + :network-stream (usocket:socket-stream socket)))))))) + +(defmethod dcc-request-reject ((message ctcp-dcc-chat-request-message) + &optional reason) + (ctcp-reply (connection message) (source message) + (format nil "ERRMSG DCC CHAT ~A" (if reason reason + "rejected")))) + +;; +;; IRC commands which make some sence in a DCC CHAT context +;; + +(defmethod quit ((connection dcc-chat-connection) + &optional message) + (when message + (ignore-errors (send-dcc-message connection message))) + (ignore-errors + (dcc-close connection))) + +;;## TODO +;; ctcp action, time, source, finger, ping+pong message generation +;; btw: those could be defined for 'normal' IRC too; currently +;; we only generate the responses to others' messages.
Modified: trunk/event.lisp ============================================================================== --- trunk/event.lisp (original) +++ trunk/event.lisp Mon Apr 30 03:56:05 2007 @@ -329,6 +329,7 @@ (remove-channel user channel) (remove-user channel user)))))))
+;;###TODO: generate these responses in a DCC CHAT context too. (macrolet ((define-ctcp-reply-hook ((message-var message-type) &body body) `(defmethod default-hook ((,message-var ,message-type)) (when (ctcp-request-p ,message-var)
Modified: trunk/package.lisp ============================================================================== --- trunk/package.lisp (original) +++ trunk/package.lisp Mon Apr 30 03:56:05 2007 @@ -149,5 +149,9 @@ :dcc-message :dcc-message-event :make-dcc-chat-connection + :ctcp-chat-initiate + :dcc-request-reject + :dcc-request-accept + :dcc-request-cancel )))
Modified: trunk/protocol.lisp ============================================================================== --- trunk/protocol.lisp (original) +++ trunk/protocol.lisp Mon Apr 30 03:56:05 2007 @@ -124,6 +124,7 @@ :initform *default-irc-server-port*) (socket :initarg :socket + :reader socket :documentation "Slot to store socket (for internal use only).") (network-stream :initarg :network-stream @@ -144,6 +145,11 @@ :initform t :documentation "Messages coming back from the server are sent to this stream.") + (dcc-offers + :accessor dcc-offers + :initform '() + :documentation "The DCC offers sent out in association with this +connection.") (dcc-connections :accessor dcc-connections :initform '() @@ -497,6 +503,14 @@ (format (output-stream connection) "~A~%" message) (force-output (network-stream connection)))
+(defmethod initialize-instance :after ((instance dcc-connection) + &rest initargs + &key &allow-other-keys) + (push instance *dcc-connections*) + (when (irc-connection instance) + (push instance (dcc-connections (irc-connection instance))))) + + (defmethod dcc-close ((connection dcc-connection)) #+(and sbcl (not sb-thread)) (sb-sys:invalidate-descriptor @@ -1186,4 +1200,3 @@ (butlast (arguments message)) (car (last (arguments message)))) (force-output stream))) -