[cl-irc-cvs] r204 - trunk
ehuelsmann at common-lisp.net
ehuelsmann at common-lisp.net
Mon Apr 30 07:56:06 UTC 2007
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)))
-
More information about the cl-irc-cvs
mailing list