diff options
Diffstat (limited to 'emacs.d/lisp/rudel/obby/.svn')
10 files changed, 3296 insertions, 0 deletions
diff --git a/emacs.d/lisp/rudel/obby/.svn/all-wcprops b/emacs.d/lisp/rudel/obby/.svn/all-wcprops new file mode 100644 index 0000000..1794a33 --- /dev/null +++ b/emacs.d/lisp/rudel/obby/.svn/all-wcprops @@ -0,0 +1,53 @@ +K 25 +svn:wc:ra_dav:version-url +V 38 +/svnroot/rudel/!svn/ver/468/trunk/obby +END +rudel-obby-client.el +K 25 +svn:wc:ra_dav:version-url +V 59 +/svnroot/rudel/!svn/ver/397/trunk/obby/rudel-obby-client.el +END +rudel-obby-state.el +K 25 +svn:wc:ra_dav:version-url +V 58 +/svnroot/rudel/!svn/ver/330/trunk/obby/rudel-obby-state.el +END +Project.ede +K 25 +svn:wc:ra_dav:version-url +V 50 +/svnroot/rudel/!svn/ver/215/trunk/obby/Project.ede +END +rudel-obby.el +K 25 +svn:wc:ra_dav:version-url +V 52 +/svnroot/rudel/!svn/ver/397/trunk/obby/rudel-obby.el +END +rudel-obby-debug.el +K 25 +svn:wc:ra_dav:version-url +V 58 +/svnroot/rudel/!svn/ver/318/trunk/obby/rudel-obby-debug.el +END +rudel-obby-server.el +K 25 +svn:wc:ra_dav:version-url +V 59 +/svnroot/rudel/!svn/ver/356/trunk/obby/rudel-obby-server.el +END +rudel-obby-errors.el +K 25 +svn:wc:ra_dav:version-url +V 59 +/svnroot/rudel/!svn/ver/319/trunk/obby/rudel-obby-errors.el +END +rudel-obby-util.el +K 25 +svn:wc:ra_dav:version-url +V 57 +/svnroot/rudel/!svn/ver/468/trunk/obby/rudel-obby-util.el +END diff --git a/emacs.d/lisp/rudel/obby/.svn/entries b/emacs.d/lisp/rudel/obby/.svn/entries new file mode 100644 index 0000000..2d21fc4 --- /dev/null +++ b/emacs.d/lisp/rudel/obby/.svn/entries @@ -0,0 +1,300 @@ +10 + +dir +545 +https://rudel.svn.sourceforge.net/svnroot/rudel/trunk/obby +https://rudel.svn.sourceforge.net/svnroot/rudel + + + +2009-10-16T01:48:03.160288Z +468 +scymtym + + + + + + + + + + + + + + +694b31df-dcbb-44e8-af88-74c7ea918228 + +rudel-obby-client.el +file + + + + +2009-11-18T14:01:44.000000Z +9cb0ae63b9f86199be36f208feb51b26 +2009-10-10T00:39:13.745463Z +397 +scymtym + + + + + + + + + + + + + + + + + + + + + +30971 + +rudel-obby-state.el +file + + + + +2009-11-18T14:01:44.000000Z +f7a018739f96fe975da0ab4cc112e7e4 +2009-10-03T01:58:59.186010Z +330 +scymtym + + + + + + + + + + + + + + + + + + + + + +4955 + +Project.ede +file + + + + +2009-11-18T14:01:44.000000Z +a99a4bf5a1243e8bd25e87d74b02db1d +2009-10-03T00:45:44.545055Z +215 +scymtym + + + + + + + + + + + + + + + + + + + + + +388 + +rudel-obby.el +file + + + + +2009-11-18T14:01:44.000000Z +af5ba069b2183fac68261ba2d34f199d +2009-10-10T00:39:13.745463Z +397 +scymtym + + + + + + + + + + + + + + + + + + + + + +15453 + +rudel-obby-debug.el +file + + + + +2009-11-18T14:01:44.000000Z +915461ef0b7ccb7dbad60a69aa973389 +2009-10-03T01:56:22.854481Z +318 +scymtym + + + + + + + + + + + + + + + + + + + + + +3300 + +rudel-obby-server.el +file + + + + +2009-11-18T14:01:44.000000Z +cd9ab22e9a8d09b558693edfc7b5505a +2009-10-03T02:08:53.322972Z +356 +scymtym + + + + + + + + + + + + + + + + + + + + + +24935 + +rudel-obby-errors.el +file + + + + +2009-11-18T14:01:44.000000Z +72c6c1dfe7ec7b8a95d5808d439088dd +2009-10-03T01:56:39.182216Z +319 +scymtym + + + + + + + + + + + + + + + + + + + + + +1839 + +rudel-obby-util.el +file + + + + +2009-11-18T14:01:44.000000Z +991ece971eaeba3b86359fc05a410b9d +2009-10-16T01:48:03.160288Z +468 +scymtym + + + + + + + + + + + + + + + + + + + + + +9523 + diff --git a/emacs.d/lisp/rudel/obby/.svn/text-base/Project.ede.svn-base b/emacs.d/lisp/rudel/obby/.svn/text-base/Project.ede.svn-base new file mode 100644 index 0000000..53d2422 --- /dev/null +++ b/emacs.d/lisp/rudel/obby/.svn/text-base/Project.ede.svn-base @@ -0,0 +1,14 @@ +;; Object rudel/obby +;; EDE project file. +(ede-proj-project "rudel/obby" + :name "obby" + :file "Project.ede" + :targets (list + (ede-proj-target-elisp "obby" + :name "obby" + :path "" + :source '("rudel-obby.el" "rudel-obby-util.el" "rudel-obby-client.el" "rudel-obby-server.el" "rudel-obby-errors.el" "rudel-obby-state.el") + :aux-packages '("rudel" "jupiter") + ) + ) + ) diff --git a/emacs.d/lisp/rudel/obby/.svn/text-base/rudel-obby-client.el.svn-base b/emacs.d/lisp/rudel/obby/.svn/text-base/rudel-obby-client.el.svn-base new file mode 100644 index 0000000..5c192db --- /dev/null +++ b/emacs.d/lisp/rudel/obby/.svn/text-base/rudel-obby-client.el.svn-base @@ -0,0 +1,973 @@ +;;; rudel-obby-client.el --- Client functions of the Rudel obby backend +;; +;; Copyright (C) 2008, 2009 Jan Moringen +;; +;; Author: Jan Moringen <scymtym@users.sourceforge.net> +;; Keywords: Rudel, obby, backend, client +;; X-RCS: $Id:$ +;; +;; This file is part of Rudel. +;; +;; Rudel is free software: you can redistribute it and/or modify it +;; under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. +;; +;; Rudel is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with Rudel. If not, see <http://www.gnu.org/licenses>. + + +;;; Commentary: +;; +;; This file contains the client part of the obby backend. + + +;;; History: +;; +;; 0.2 - State machine. +;; +;; 0.1 - Initial revision. + + +;;; Code: +;; + +(require 'eieio) + +(require 'jupiter) + +(require 'rudel-state-machine) +(require 'rudel-operations) +(require 'rudel-chat) + +(require 'rudel-obby-errors) +(require 'rudel-obby-util) +(require 'rudel-obby-state) + + +;;; Class rudel-obby-client-state-new +;; + +(defclass rudel-obby-client-state-new + (rudel-obby-client-connection-state) + () + "Start state of newly established connections.") + +(defmethod rudel-obby/obby_welcome + ((this rudel-obby-client-state-new) version) + "Handle obby 'welcome' message." + ;; Examine announced protocol version. + (with-parsed-arguments ((version number)) + (message "Received Obby welcome message (version %d)" version)) + ;; Start encryption handshake + 'encryption-negotiate) + + +;;; Class rudel-obby-client-state-encryption-negotiate +;; + +(defclass rudel-obby-client-state-encryption-negotiate + (rudel-obby-client-connection-state) + () + "Start state of the encryption handshake.") + +(defmethod rudel-obby/net6_encryption + ((this rudel-obby-client-state-encryption-negotiate) value) + "Handle net6 'encryption' message." + (rudel-send this "net6_encryption_ok") + 'encryption-start) + + +;;; Class rudel-obby-client-connection-encryption-start +;; + +(defclass rudel-obby-client-state-encryption-start + (rudel-obby-client-connection-state) + () + "Second state of the encryption handshake.") + +(defmethod rudel-obby/net6_encryption_begin + ((this rudel-obby-client-state-encryption-start)) + "Handle net6 'encryption_begin' message." + ;; Start TLS encryption for the connection. + (with-slots (connection) this + (with-slots (socket) connection + (when (rudel-process-object socket :supports-tls) + (rudel-tls-start-tls socket) + (sit-for 1)))) + + ;; The connection is now established + 'joining) + +(defmethod rudel-obby/net6_encryption_failed + ((this rudel-obby-client-state-encryption-start)) + "Handle net6 'encryption_failed' message." + ;; The connection is now established; without encryption though + 'joining) + + +;;; Class rudel-obby-client-state-joining +;; + +(defclass rudel-obby-client-state-joining + (rudel-obby-client-connection-state) + () + "First state after the connection has been properly set up.") + +(defmethod rudel-enter ((this rudel-obby-client-state-joining)) + "When entering this state, send a login request." + ;; Send login request with username and color. This can easily fail + ;; (resulting in response 'net6_login_failed') if the username or + ;; color is already taken. + (with-slots (info) (oref this connection) + (let ((username (plist-get info :username)) + (color (plist-get info :color)) + (global-password (plist-get info :global-password)) + (user-password (plist-get info :user-password))) + (apply #'rudel-send + this + "net6_client_login" + username (rudel-obby-format-color color) + (append (when global-password + (list global-password)) + (when (and global-password user-password) + (list user-password)))))) + nil) + +(defmethod rudel-obby/obby_sync_init + ((this rudel-obby-client-state-joining) count) + "Handle obby 'sync_init' message." + ;; Switch to 'synching' state, passing the number of synchronization + ;; items. + (with-parsed-arguments ((count number)) + (list 'session-synching count))) + +(defmethod rudel-obby/net6_login_failed + ((this rudel-obby-client-state-joining) reason) + "Handle net6 'login_failed' message." + (with-parsed-arguments ((reason number)) + (with-slots (connection) this + (let ((error-data + (cond + ;; Invalid username + ((= reason rudel-obby-error-username-invalid) + (cons 'rudel-obby-username-invalid nil)) + ;; Username in use + ((= reason rudel-obby-error-username-in-use) + (cons 'rudel-obby-username-in-use nil)) + ;; Color in use + ((= reason rudel-obby-error-color-in-use) + (cons 'rudel-obby-color-in-use nil)) + ;; Wrong global password + ((= reason rudel-obby-error-wrong-global-password) + (cons 'rudel-obby-wrong-global-password nil)) + ;; Wrong user password + ((= reason rudel-obby-error-wrong-user-password) + (cons 'rudel-obby-wrong-user-password nil)) + ;; Otherwise, signal a generic join error + (t (cons 'rudel-join-error nil))))) + + ;; Switch to 'join-failed' state, pass the error data. + (list 'join-failed error-data)))) + ) + + +;;; Class rudel-obby-client-state-join-failed +;; + +(defclass rudel-obby-client-state-join-failed + (rudel-obby-client-connection-state) + ((error-symbol :initarg :error-symbol + :type symbol + :documentation + "Error symbol describing the reason for the +login failure.") + (error-data :initarg :error-data + :type list + :documentation + "Additional error data describing the login +failure.")) + "State for failed login attempts.") + +(defmethod rudel-enter ((this rudel-obby-client-state-join-failed) + error) + "When the state is entered, store the error data passed in ERROR." + (with-slots (error-symbol error-data) this + (setq error-symbol (car error) + error-data (cdr error))) + nil) + + +;;; Class rudel-obby-client-state idle +;; + +(defclass rudel-obby-client-state-idle + (rudel-obby-client-connection-state + rudel-obby-document-handler) + () + "Default state of the connection.") + +(defmethod rudel-obby/net6_client_join + ((this rudel-obby-client-state-idle) + client-id name encryption user-id color) + "Handle net6 'client_join' message." + (with-parsed-arguments ((client-id number) + (user-id number) + (color color)) + (with-slots (connection) this + (with-slots (session) connection + (let ((user (rudel-find-user session user-id + #'eq #'rudel-id))) + (if user + ;; If we have such a user object, update its state. + (with-slots ((client-id1 client-id) + (color1 color) + connected + (encryption1 encryption)) user + (setq client-id1 client-id + color1 color + connected t + encryption1 (string= encryption "1")) + + ;; Run the change hook of the user object. + (object-run-hook-with-args user 'change-hook)) + ;; Otherwise, create a new user object. + (let ((user (rudel-obby-user + name + :client-id client-id + :user-id user-id + :connected t + :encryption (string= encryption "1") + :color color))) + (rudel-add-user session user)))))) + (message "Client joined: %s %s" name color)) + nil) + +(defmethod rudel-obby/net6_client_part + ((this rudel-obby-client-state-idle) client-id) + "Handle net6 'client_part' message." + ;; Find the user object, associated to the client id. Remove the + ;; client id and change the user's state to disconnected. + (with-parsed-arguments ((client-id number)) + (with-slots (connection) this + (with-slots (session) connection + (let ((user (rudel-find-user session client-id + #'eql #'rudel-client-id))) + (if user + (with-slots (client-id connected) user + ;; Set slot values. + (setq client-id nil + connected nil) + + ;; Run the change hook of the user object. + (object-run-hook-with-args user 'change-hook)) + (display-warning + '(rudel obby) + (format "Cannot find user for client id: %d" + client-id) + :warning)))))) + nil) + +(defmethod rudel-obby/obby_user_colour + ((this rudel-obby-client-state-idle) user-id color) + "Handle obby 'user_colour' message." + (with-parsed-arguments ((user-id number) + (color color)) + ;; Find user object and set color. + (with-slots (connection) this + (with-slots (session) connection + (let ((user (rudel-find-user session user-id + #'= #'rudel-id))) + (with-slots ((name :object-name) (color1 :color)) user + ;; Set color in user object. + (setq color1 color) + + ;; Run the change hook of the user object. + (object-run-hook-with-args user 'change-hook) + + ;; Update overlays. + (rudel-overlay-set-face-attributes + (rudel-overlay-make-face-symbol 'author name) + color1)))))) + nil) + +(defmethod rudel-obby/obby_document_create + ((this rudel-obby-client-state-idle) + owner-id doc-id name suffix encoding) + "Handle obby 'document_create' message." + (with-parsed-arguments ((owner-id number) + (doc-id number) + (suffix number) + (encoding coding-system)) + (with-slots (connection) this + (with-slots (session) connection + (let ((owner (rudel-find-user session owner-id + #'= #'rudel-id))) + (rudel-add-document session (rudel-obby-document + name + :subscribed (list owner) + :id doc-id + :owner-id owner-id + :suffix suffix)))) + (message "New document: %s" name))) + nil) + +(defmethod rudel-obby/obby_document_remove + ((this rudel-obby-client-state-idle) doc-id) + "Handle obby 'document_remove' message." + (with-parsed-arguments ((doc-id document-id)) + (with-slots (connection) this + (with-slots (session) connection + (let ((document (rudel-find-document + session doc-id + #'equal #'rudel-both-ids))) + (if document + (progn + (rudel-remove-document session document) + (with-slots ((name :object-name)) document + (message "Document removed: %s" name))) + (display-warning + '(rudel obby) + (format "Document not found: %s" doc-id) + :warning)))))) + nil) + +(defmethod rudel-obby/obby_document/rename + ((this rudel-obby-client-state-idle) + document user new-name new-suffix) + "Handle obby 'rename' submessage of the 'obby_document' message." + (with-parsed-arguments ((new-suffix number)) + (with-slots ((name :object-name) suffix) document + (setq name new-name + suffix new-suffix))) + nil) + +(defmethod rudel-obby/obby_document/subscribe + ((this rudel-obby-client-state-idle) + document user-id) + "Handle 'subscribe' submessage of obby 'document' message." + (with-parsed-arguments ((user-id number)) + (with-slots (connection) this + (with-slots (session) connection + (let ((user (rudel-find-user session user-id + #'= #'rudel-id))) + (rudel-add-user document user))))) + nil) + +(defmethod rudel-obby/obby_document/unsubscribe + ((this rudel-obby-client-state-idle) + document user-id) + "Handle 'unsubscribe' submessage of obby 'document' message." + (with-parsed-arguments ((user-id number)) + (with-slots (connection) this + (with-slots (session) connection + (let ((user (rudel-find-user session user-id + #'= #'rudel-id))) + (rudel-remove-user document user))))) + nil) + +(defmethod rudel-obby/obby_document/record + ((this rudel-obby-client-state-idle) + document user-id local-revision remote-revision + action &rest arguments) + "Handle 'record' submessage of obby 'document' message." + (with-parsed-arguments ((user-id number) + (local-revision number) + (remote-revision number)) + ;; Locate the user. + (let ((user (with-slots (connection) this + (with-slots (session) connection + (rudel-find-user session user-id + #'= #'rudel-id))))) + (if user + (condition-case error + ;; Try to dispatch + (rudel-dispatch + this "rudel-obby/obby_document/record/" action + (append (list document user local-revision remote-revision) + arguments)) + ;; Warn if we failed to locate or execute the + ;; method. Return nil in this case, so we remain in the + ;; current state. + (rudel-dispatch-error + (progn + (display-warning + '(rudel obby) + (format "%s: no method (%s: %s): `%s:%s'; arguments: %s" + (object-print this) (car error) (cdr error) + "rudel-obby/obby_document/record/" action arguments) + :debug) + nil))) + ;; If we did not find the user, warn. + (progn + (display-warning + '(rudel obby) + (format "User not found: %d" user-id) + :warning) + nil)))) + ) + +(defmethod rudel-obby/obby_document/record/ins + ((this rudel-obby-client-state-idle) + document user local-revision remote-revision + position data) + "Handle 'ins' submessage of 'record' submessage of obby 'document' message." + (with-parsed-arguments ((position number)) + (let ((operation (jupiter-insert + (format "insert-%d-%d" + remote-revision local-revision) + :from position + :data data))) + (with-slots (connection) this + (rudel-remote-operation connection + document user + remote-revision local-revision + operation)))) + nil) + +(defmethod rudel-obby/obby_document/record/del + ((this rudel-obby-client-state-idle) + document user local-revision remote-revision + position length) + "Handle 'del' submessage of 'record' submessage of obby 'document' message." + (with-parsed-arguments ((position number) + (length number)) + (let ((operation (jupiter-delete + (format "delete-%d-%d" + remote-revision local-revision) + :from position + :to (+ position length)))) + (with-slots (connection) this + (rudel-remote-operation connection + document user + remote-revision local-revision + operation)))) + nil) + +(defmethod rudel-obby/obby_document/record/split + ((this rudel-obby-client-state-idle) + document user local-revision remote-revision + &rest operations) + "Handle 'split' submessage of 'record' submessage of obby 'document' message." + (let ((operation (rudel-message->operation + (cons "split" operations) + local-revision remote-revision))) + (with-slots (connection) this + (rudel-remote-operation connection + document user + remote-revision local-revision + operation))) + nil) + +(defmethod rudel-obby/obby_document/record/noop + ((this rudel-obby-client-state-idle) + document user local-revision remote-revision) + "Handle 'noop' submessage of 'record' submessage of obby 'document' message." + (let ((operation (jupiter-nop + (format "nop-%d-%d" + remote-revision local-revision)))) + (with-slots (connection) this + (rudel-remote-operation connection + document user + remote-revision local-revision + operation))) + nil) + +(defmethod rudel-obby/obby_message ((this rudel-obby-client-state-idle) + sender text) + "Handle obby 'message' message" + (with-parsed-arguments ((sender number)) + (with-slots (session) (oref this :connection) + (let ((sender (rudel-find-user session sender #'eq #'rudel-id))) + (rudel-chat-dispatch-message sender text)))) + nil) + + +;;; Class rudel-obby-client-state-session-synching +;; + +(defclass rudel-obby-client-state-session-synching + (rudel-obby-client-connection-state) + ((all-items :initarg :all-items + :type (integer 0) + :documentation + "Total number of synchronization items expected + to receive from the server.") + (remaining-items :initarg :remaining-items + :type (integer 0) + :documentation + "Number of synchronization items not yet + received from the server.") + (have-self :initarg :have-self + :type boolean + :documentation + "Flag that remembers, whether the session has + a 'self' user object.")) + "State used for synching session data.") + +(defmethod rudel-enter ((this rudel-obby-client-state-session-synching) + num-items) + "When entering state, store number of expected items." + (with-slots (all-items remaining-items have-self) this + (setq all-items num-items + remaining-items num-items + have-self nil)) + nil) + +(defmethod rudel-obby/net6_client_join + ((this rudel-obby-client-state-session-synching) + client-id name encryption user-id color) + "Handle net6 'client_join' message." + (with-parsed-arguments ((client-id number) + (user-id number) + (color color)) + (with-slots (connection remaining-items have-self) this + (with-slots (session) connection + ;; Construct user object and add it to the session. + (let ((user (rudel-obby-user + name + :client-id client-id + :user-id user-id + :connected t + :encryption (string= encryption "1") + :color color))) + (rudel-add-user session user) + + ;; The first user object describes the user of this client. + (unless have-self + (with-slots (self) session + (setq self user + have-self t))))) + + ;; Decrease number of not yet received synchronization items. + (decf remaining-items))) + nil) + +(defmethod rudel-obby/obby_sync_usertable_user + ((this rudel-obby-client-state-session-synching) user-id name color) + "Handle obby 'sync_usertable_user' message." + (with-parsed-arguments ((user-id number) + (color color)) + (with-slots (connection remaining-items) this + (with-slots (session) connection + (rudel-add-user session (rudel-obby-user + name + :user-id user-id + :connected nil + :color color))) + + ;; Decrease number of not yet received synchronization items. + (decf remaining-items))) + nil) + +(defmethod rudel-obby/obby_sync_doclist_document + ((this rudel-obby-client-state-session-synching) + owner-id doc-id name suffix encoding &rest subscribed-user-ids) + "Handle obby 'sync_doclist_document' message." + (with-parsed-arguments ((doc-id number) + (owner-id number) + (suffix number) + (encoding coding-system)) + (with-slots (connection remaining-items) this + (with-slots (session) connection + ;; Retrieve the subscribed users + (let ((subscribed-users + (mapcar + (lambda (user-id) + (with-parsed-arguments ((user-id number)) + (rudel-find-user session user-id + #'= #'rudel-id))) + subscribed-user-ids))) + + ;; Make a new document with the list of subscribed users. + (rudel-add-document session (rudel-obby-document + name + :subscribed subscribed-users + :id doc-id + :owner-id owner-id + :suffix suffix)))) + + ;; Decrease number of not yet received synchronization items. + (decf remaining-items))) + nil) + +(defmethod rudel-obby/obby_sync_final + ((this rudel-obby-client-state-session-synching)) + "Handle obby 'sync_final' message." + 'idle) + +(defmethod object-print ((this rudel-obby-client-state-session-synching) + &rest strings) + "Append number of remaining items to string representation." + (with-slots (remaining-items) this + (call-next-method this (format " remaining: %d" remaining-items)))) + + +;;; Class rudel-obby-client-state-subscribing +;; + +(defclass rudel-obby-client-state-subscribing + (rudel-obby-client-connection-state + rudel-obby-document-handler) + ((document :initarg :document + :type rudel-obby-document-child + :documentation + "")) + "") + +(defmethod rudel-enter ((this rudel-obby-client-state-subscribing) + user document) + "When entering this state, send a subscription request to the server." + (with-slots ((document1 :document)) this + (setq document1 document) + + (with-slots ((doc-id :id) owner-id) document1 + (with-slots (user-id) user + (rudel-send this "obby_document" + (format "%x %x" owner-id doc-id) + "subscribe" + (format "%x" user-id))))) + nil) + +(defmethod rudel-obby/obby_document/sync_init + ((this rudel-obby-client-state-subscribing) + document num-bytes) + "Handle obby 'sync_init' message." + (with-parsed-arguments ((num-bytes number)) + (with-slots (documents) this + (if (= num-bytes 0) + 'idle + (list 'document-synching document num-bytes)))) + ) + + +;;; Class rudel-obby-client-state-document-synching +;; + +(defclass rudel-obby-client-state-document-synching + (rudel-obby-client-connection-state + rudel-obby-document-handler) + ((document :initarg :document + :type rudel-obby-document-child + :documentation + "") + (all-bytes :initarg :all-bytes + :type (integer 0) + :documentation + "") + (remaining-bytes :initarg :remaining-bytes + :type (integer 0) + :documentation + "")) + "") + +(defmethod rudel-enter ((this rudel-obby-client-state-document-synching) + document num-bytes) + "" + (with-slots ((document1 :document) all-bytes remaining-bytes) this + (setq document1 document + all-bytes num-bytes + remaining-bytes num-bytes)) + nil) + +(defmethod rudel-obby/obby_document/sync_chunk + ((this rudel-obby-client-state-document-synching) + document data user-id) + "Handle obby 'sync_chunk' message." + (with-parsed-arguments ((user-id number)) + (with-slots (connection remaining-bytes) this + (with-slots (session) connection + (let* ((user (unless (zerop user-id) + (rudel-find-user session user-id + #'= #'rudel-id))) + (operation (rudel-insert-op "bulk-insert" + :from nil + :data data))) + (rudel-remote-operation document user operation))) + + ;; After all bytes are transferred, go back to idle state. + (decf remaining-bytes (string-bytes data)) + (if (= remaining-bytes 0) + 'idle + nil))) + ) + +(defmethod object-print ((this rudel-obby-client-state-document-synching) + &rest strings) + "Append number of remaining items to string representation." + (with-slots (remaining-bytes) this + (call-next-method this (format " remaining: %d" remaining-bytes)))) + + +;;; Class rudel-obby-client-state-they-finalized +;; + +(defclass rudel-obby-client-state-they-finalized + (rudel-obby-client-connection-state) + () + "State used to indicate that the connection was closed by the peer.") + + +;;; Client connection states. +;; + +(defvar rudel-obby-client-connection-states + '((new . rudel-obby-client-state-new) + (encryption-negotiate . rudel-obby-client-state-encryption-negotiate) + (encryption-start . rudel-obby-client-state-encryption-start) + (joining . rudel-obby-client-state-joining) + (join-failed . rudel-obby-client-state-join-failed) + (idle . rudel-obby-client-state-idle) + (session-synching . rudel-obby-client-state-session-synching) + (subscribing . rudel-obby-client-state-subscribing) + (document-synching . rudel-obby-client-state-document-synching) + (they-finalized . rudel-obby-client-state-they-finalized)) + "Name symbols and classes of connection states.") + + +;;; Class rudel-obby-connection +;; + +(defclass rudel-obby-connection (rudel-obby-socket-owner + rudel-connection + rudel-state-machine) + ((info :initarg :info + :type list + :documentation + "Stores connection information for later use.") + (contexts :initarg :contexts + :type hash-table + :documentation + "Contains jupiter context objects for all +documents.")) + "Class rudel-obby-connection ") + +(defmethod initialize-instance ((this rudel-obby-connection) &rest slots) + ;; Initialize slots of THIS + (when (next-method-p) + (call-next-method)) + + ;; Create a new hash-table object to hold jupiter contexts + ;; associated to documents. + (with-slots (contexts) this + (setq contexts (make-hash-table :test #'equal))) + + ;; Register states. + (rudel-register-states this rudel-obby-client-connection-states) + ) + +(defmethod rudel-register-state ((this rudel-obby-connection) + symbol state) + "Register SYMBOL and STATE and set connection slot of STATE." + ;; Associate THIS connection to STATE. + (oset state :connection this) + + ;; Register STATE. + (when (next-method-p) + (call-next-method)) + ) + +(defmethod rudel-disconnect ((this rudel-obby-connection)) + "" + (when (next-method-p) + (call-next-method))) + +(defmethod rudel-close ((this rudel-obby-connection)) + "" + ;; Move the state machine into an error state. + (rudel-switch this 'they-finalized) + + ;; Terminate the session. + (with-slots (session) this + (rudel-end session))) + +(defmethod rudel-find-context ((this rudel-obby-connection) document) + "Return the jupiter context associated to DOCUMENT in THIS connection." + (with-slots (contexts) this + (gethash (oref document :id) contexts))) + +(defmethod rudel-add-context ((this rudel-obby-connection) document) + "Add a jupiter context for DOCUMENT to THIS connection." + (with-slots (contexts) this + (with-slots ((doc-name :object-name) (doc-id :id)) document + (puthash doc-id + (jupiter-context (format "%s" doc-name)) + contexts))) + ) + +(defmethod rudel-remove-context ((this rudel-obby-connection) document) + "Remove the jupiter context associated to DOCUMENT from THIS connection." + (with-slots (contexts) this + (remhash (oref document :id) contexts))) + +(defmethod rudel-message ((this rudel-obby-connection) message) + "Dispatch MESSAGE to the current state of THIS object. +If the state has no suitable method, generate a warning, but do +nothing else." + ;; Dispatch message to state. + (rudel-accept this message)) + +(defmethod rudel-change-color- ((this rudel-obby-connection) color) + "" + (rudel-send this "obby_user_colour" + (rudel-obby-format-color color))) + +(defmethod rudel-publish ((this rudel-obby-connection) document) + "" + ;; Create a new jupiter context for DOCUMENT. + (rudel-add-context this document) + + ;; Announce the new document to the server. + (with-slots ((name :object-name) id buffer) document + (rudel-send this "obby_document_create" + (format "%x" id) + name + "UTF-8" + (with-current-buffer buffer + (buffer-string)))) + ) + +(defmethod rudel-unpublish ((this rudel-obby-connection) document) + "Remove DOCUMENT from the obby session THIS is connected to." + ;; Request removal of DOCUMENT. + (with-slots ((doc-id :id) owner-id) document + (rudel-send this "obby_document_remove" + (format "%x %x" owner-id doc-id))) + + ;; Remove the jupiter context for DOCUMENT. + (rudel-remove-context this document) + ) + +(defmethod rudel-subscribe-to ((this rudel-obby-connection) document) + "" + ;; Create a new jupiter context for DOCUMENT. + (rudel-add-context this document) + + ;; Switch to subscribing state and wait until the state goes back to + ;; idle. + (with-slots (session) this + (with-slots (self) session + (rudel-switch this 'subscribing self document))) + + (lexical-let ((reporter (make-progress-reporter "Subscribing " 0.0 1.0))) + (flet ((display-progress (state) + (cond + ;; Syncing document content, we can provide detailed progress. + ((and (consp state) + (eq (car state) 'document-synching)) + (with-slots (all-bytes remaining-bytes) (cdr state) + (progress-reporter-force-update + reporter + (- 1.0 (/ (float remaining-bytes) (float all-bytes))) + (format "Subscribing (%s) " (car state))))) + + ;; For other states, we just spin. + ((consp state) + (progress-reporter-force-update + reporter 0.5 + (format "Subscribing (%s) " (car state)))) + + ;; Done + (t + (progress-reporter-force-update reporter 1.0 "Subscribing ") + (progress-reporter-done reporter))))) + (rudel-state-wait this '(idle) '(they-finalized) #'display-progress))) + + ;; We receive a notification of our own subscription from the + ;; server. Consequently we do not add SELF to the list of subscribed + ;; users of DOCUMENT. + ) + +(defmethod rudel-unsubscribe-from ((this rudel-obby-connection) document) + "" + ;; Delete the jupiter context for DOCUMENT. + (rudel-remove-context this document) + + ;; Announce the end of our subscription to the server. + (with-slots (session) this + (with-slots (user-id) (oref session :self) + (with-slots ((doc-id :id) owner-id) document + (rudel-send this "obby_document" + (format "%x %x" owner-id doc-id) + "unsubscribe" + (format "%x" user-id))))) + + ;; We receive a notification of the end of our own subscription from + ;; the server. Consequently we do not remove SELF from the list of + ;; subscribed users of DOCUMENT. + ) + +(defmethod rudel-local-insert ((this rudel-obby-connection) + document position data) + "" + (rudel-local-operation + this + document + (jupiter-insert "insert" :from position :data data))) + +(defmethod rudel-local-delete ((this rudel-obby-connection) + document position length) + "" + (rudel-local-operation + this + document + (jupiter-delete "delete" :from position :to (+ position length)))) + +(defmethod rudel-local-operation ((this rudel-obby-connection) + document operation) + "Handle OPERATION performed on DOCUMENT by sending a message through THIS connection." + ;; Convert character positions in OPERATION to byte positions, since + ;; the obby protocol works with byte positions, but Emacs uses + ;; character positions. + (with-slots (buffer) document + (rudel-obby-char->byte operation buffer)) + + ;; Find jupiter context for DOCUMENT. + (let ((context (rudel-find-context this document))) + + ;; Notify the server of the operation. + (with-slots (owner-id (doc-id :id)) document + (with-slots (local-revision remote-revision) context + (apply #'rudel-send + this + "obby_document" + (format "%x %x" owner-id doc-id) + "record" + (format "%x" local-revision) + (format "%x" remote-revision) + (rudel-operation->message operation)))) + + ;; Submit the operation to the jupiter context. + (jupiter-local-operation context operation)) + ) + +(defmethod rudel-remote-operation ((this rudel-obby-connection) + document user + remote-revision local-revision + operation) + "Handle OPERATION received through THIS connection performed by USER on DOCUMENT." + (let* (;; Find jupiter context for DOCUMENT. + (context (rudel-find-context this document)) + ;; And transform the operation. + (transformed (jupiter-remote-operation + context + remote-revision local-revision + operation))) + + ;; Convert byte positions in OPERATION to character positions, + ;; since the obby protocol works with byte positions, but Emacs + ;; uses character positions. + (with-slots (buffer) document + (rudel-obby-byte->char transformed buffer)) ;; TODO operation's responsibility? + + ;; Apply the transformed operation to the document. + (rudel-remote-operation document user transformed)) + ) + +(provide 'rudel-obby-client) +;;; rudel-obby-client.el ends here diff --git a/emacs.d/lisp/rudel/obby/.svn/text-base/rudel-obby-debug.el.svn-base b/emacs.d/lisp/rudel/obby/.svn/text-base/rudel-obby-debug.el.svn-base new file mode 100644 index 0000000..8f5f168 --- /dev/null +++ b/emacs.d/lisp/rudel/obby/.svn/text-base/rudel-obby-debug.el.svn-base @@ -0,0 +1,122 @@ +;;; rudel-obby-debug.el --- Debugging functions for obby backend +;; +;; Copyright (C) 2009 Jan Moringen +;; +;; Author: Jan Moringen <scymtym@users.sourceforge.net> +;; Keywords: Rudel, obby, debugging +;; X-RCS: $Id:$ +;; +;; This program is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. +;; +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see <http://www.gnu.org/licenses>. + + +;;; Commentary: +;; +;; Debugging functions for the obby backend. + + +;;; History: +;; +;; 0.1 - Initial revision. + + +;;; Code: +;; + +(require 'eieio) + +(require 'rudel-debug) + +(require 'rudel-obby-util) + + +;;; Variables +;; + +(defvar rudel-obby-debug-old-state nil + "Saves state of state machines across one function call.") + + +;;; Functions +;; + +(defmethod rudel-send :before ((this rudel-obby-socket-owner) + name &rest arguments) + "Print NAME and ARGUMENTS to debug stream." + (let ((message (apply #'rudel-obby-assemble-message + name arguments))) + + (with-slots (socket) this + (rudel-debug-stream-insert + (rudel-debug-stream-name socket) + :sent + (concat (substring message 0 (min (length message) 100)) + (when (> (length message) 100) + "...")) + (append (list name) arguments)))) + ) + +(defmethod rudel-receive :before ((this rudel-obby-socket-owner) data) + "Print DATA to debug stream." + (with-slots (socket) this + (rudel-debug-stream-insert + (rudel-debug-stream-name socket) + :received + (concat (substring data 0 (min (length data) 100)) + (when (> (length data) 100) + "...")))) + ) + +(defmethod rudel-message :before ((this rudel-obby-socket-owner) + message) + "Print DATA to debug stream." + (let ((data (apply #'rudel-obby-assemble-message message))) + + (with-slots (socket) this + (rudel-debug-stream-insert + (rudel-debug-stream-name socket) + :received-processed + (concat (substring data 0 (min (length data) 100)) + (when (> (length data) 100) + "...")) + message) + )) + ) + +(defmethod rudel-switch :before ((this rudel-obby-socket-owner) + state &rest arguments) + "Store name of STATE for later printing." + (with-slots (state) this + (setq rudel-obby-debug-old-state + (if state + (object-name-string state) + "#start"))) + ) + +(defmethod rudel-switch :after ((this rudel-obby-socket-owner) + state &rest arguments) + "Print STATE and ARGUMENTS to debug stream." + (with-slots (socket state) this + (let ((old-state rudel-obby-debug-old-state) + (new-state (object-name-string state))) + (unless (string= old-state new-state) + (rudel-debug-stream-insert + (rudel-debug-stream-name socket) + :special + (if arguments + (format "%s -> %s %s" old-state new-state arguments) + (format "%s -> %s" old-state new-state)))))) + ) + +(provide 'rudel-obby-debug) +;;; rudel-obby-debug.el ends here diff --git a/emacs.d/lisp/rudel/obby/.svn/text-base/rudel-obby-errors.el.svn-base b/emacs.d/lisp/rudel/obby/.svn/text-base/rudel-obby-errors.el.svn-base new file mode 100644 index 0000000..689d4a8 --- /dev/null +++ b/emacs.d/lisp/rudel/obby/.svn/text-base/rudel-obby-errors.el.svn-base @@ -0,0 +1,65 @@ +;;; rudel-obby-errors.el --- Error data used in the obby Rudel backend +;; +;; Copyright (C) 2009 Jan Moringen +;; +;; Author: Jan Moringen <scymtym@users.sourceforge.net> +;; Keywords: Rudel, obby, errors +;; X-RCS: $Id:$ +;; +;; This file is part of Rudel. +;; +;; Rudel is free software: you can redistribute it and/or modify it +;; under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. +;; +;; Rudel is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with Rudel. If not, see <http://www.gnu.org/licenses>. + + +;;; Commentary: +;; +;; This file contains definitions of error conditions and numeric +;; error codes used in the Rudel obby backend. + + +;;; History: +;; +;; 0.1 - Initial revision. + + +;;; Code: +;; + + +;;; Obby protocol error codes +;; + +(defconst rudel-obby-error-username-invalid #x0001 + "Error code for invalid username.") + +(defconst rudel-obby-error-username-in-use #x0002 + "Error code for username already in use.") + +(defconst rudel-obby-error-color-in-use #x0100 + "Error code for color already in use.") + +(defconst rudel-obby-error-wrong-global-password #x0101 + "Error code for wrong global password.") + +(defconst rudel-obby-error-wrong-user-password #x0102 + "Error code for wrong user password.") + +(defconst rudel-obby-error-protocol-version-mismatch #x0103 + "Error code for protocol version mismatch.") + +(defconst rudel-obby-error-not-encrypted #x0104 + "Error code for not encrypted.") + +(provide 'rudel-obby-errors) +;;; rudel-obby-errors.el ends here diff --git a/emacs.d/lisp/rudel/obby/.svn/text-base/rudel-obby-server.el.svn-base b/emacs.d/lisp/rudel/obby/.svn/text-base/rudel-obby-server.el.svn-base new file mode 100644 index 0000000..5bf1158 --- /dev/null +++ b/emacs.d/lisp/rudel/obby/.svn/text-base/rudel-obby-server.el.svn-base @@ -0,0 +1,798 @@ +;;; rudel-obby-server.el --- Server component of the Rudel obby backend +;; +;; Copyright (C) 2008, 2009 Jan Moringen +;; +;; Author: Jan Moringen <scymtym@users.sourceforge.net> +;; Keywords: Rudel, obby, backend, server +;; X-RCS: $Id:$ +;; +;; This file is part of Rudel. +;; +;; Rudel is free software: you can redistribute it and/or modify it +;; under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. +;; +;; Rudel is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with Rudel. If not, see <http://www.gnu.org/licenses>. + + +;;; Commentary: +;; +;; This file contains the server part of the obby backend for Rudel. +;; +;; It is implemented using one state machine (class +;; `rudel-obby-client') for each client connection. These state +;; machines have the following states: +;; +;; + new `rudel-obby-server-state-new' +;; + encryption-negotiate `rudel-obby-server-state-encryption-negotiate' +;; + before-join `rudel-obby-server-state-before-join' +;; + idle `rudel-obby-server-state-idle' + + +;;; History: +;; +;; 0.2 - State machine. +;; +;; 0.1 - Initial revision. + + +;;; Code: +;; + +(eval-when-compile + (require 'cl)) + +(require 'eieio) + +(require 'jupiter) + +(require 'rudel-state-machine) + +(require 'rudel-obby-errors) +(require 'rudel-obby-util) +(require 'rudel-obby-state) + + +;;; Class rudel-obby-server-state-new +;; + +(defclass rudel-obby-server-state-new + (rudel-obby-server-connection-state) + () + "State in which new connections start out.") + +(defmethod rudel-enter ((this rudel-obby-server-state-new)) + "Sends welcome messages to the client and starts the session +timeout timer." + ;; Send greeting sequence to the client. + (rudel-send this + "obby_welcome" + (number-to-string rudel-obby-protocol-version)) + + ;; Switch to encryption negotiation state. + 'encryption-negotiate) + + +;;; Class rudel-obby-server-state-encryption-negotiate +;; + +(defclass rudel-obby-server-state-encryption-negotiate + (rudel-obby-server-connection-state) + () + "Encryption negotiation state.") + +(defmethod rudel-enter ((this rudel-obby-server-state-encryption-negotiate)) + "Send net6 'encryption' message requesting to not enable encryption." + (rudel-send this "net6_encryption" "0") + nil) + +(defmethod rudel-obby/net6_encryption_ok + ((this rudel-obby-server-state-encryption-negotiate)) + "Handle net6 'encryption_ok' message. +Even if the client requests an encrypted connection, we cancel +the negotiation." + (rudel-send this "net6_encryption_failed") + 'before-join) + +(defmethod rudel-obby/net6_encryption_failed + ((this rudel-obby-server-state-encryption-negotiate)) + "Handle net6 'encryption_failed' message. +No action has to be taken, since the client simply proceeds after +failed encryption negotiation." + 'before-join) + + +;;; Class rudel-obby-server-state-before-join +;; + +(defclass rudel-obby-server-state-before-join + (rudel-obby-server-connection-state) + () + "Waiting for client request joining the session.") + +(defmethod rudel-obby/net6_client_login + ((this rudel-obby-server-state-before-join) username color + &optional global-password user-password) + "Handle net6 'client_login' message." + (with-parsed-arguments ((color color)) + (with-slots (server + (client-id :id) + user + encryption) (oref this :connection) + ;; Make sure USERNAME and COLOR are valid. + (let ((error (rudel-check-username-and-color + server username color))) + (if error + ;; If USERNAME or COLOR are invalid, send the error code + ;; to the client and stay in the current state. + (progn + (rudel-send this + "net6_login_failed" + (format "%x" error)) + nil) + + ;; Create a user object for this client and add it to the + ;; server. + (setq user (rudel-make-user + server + username client-id color encryption)) + (rudel-add-user server user) + + ;; Broadcast the join event to all clients (including the + ;; new one). + (with-slots ((name :object-name) color (user-id :user-id)) user + (rudel-broadcast this (list 'exclude (oref this :connection)) + "net6_client_join" + (format "%x" client-id) + name + "0" + (format "%x" user-id) + (rudel-obby-format-color color))) + + ;; Get the new client up to date: + ;; - transmit user list + ;; - connected users + ;; - disconnected users + ;; - transmit document list + (with-slots (users clients documents) server + ;; Send number of synchronization items: sum of numbers of + ;; offline users and documents. + (let ((number-of-items (+ (length users) (length documents)))) + (rudel-send this + "obby_sync_init" + (format "%x" number-of-items))) + + ;; Transmit list of connected users. + (dolist (client clients) + (with-slots ((client-id :id) user) client + (when user + (with-slots ((name :object-name) + color + (user-id :user-id)) user + (rudel-send this + "net6_client_join" + (format "%x" client-id) + name + "0" + (format "%x" user-id) + (rudel-obby-format-color color)))))) + + ;; Transmit list of disconnected users. + (let ((offline-users (remove-if #'rudel-connected users))) + (dolist (user offline-users) + (with-slots ((name :object-name) user-id color) user + (rudel-send this + "obby_sync_usertable_user" + (format "%x" user-id) + name + (rudel-obby-format-color color))))) + + ;; Transmit document list + (dolist (document documents) + (with-slots ((name :object-name) + (doc-id :id) + owner-id + suffix + subscribed) document + (apply #'rudel-send + this + "obby_sync_doclist_document" + (format "%x" owner-id) + (format "%x" doc-id) + name + (format "%x" suffix) + "UTF-8" + (mapcar + (lambda (user1) ;; TODO we could use `user' here, but there is a bug in cl + (format "%x" (rudel-id user1))) + subscribed))))) + + (rudel-send this "obby_sync_final") + 'idle)))) + ) + + +;;; Class rudel-obby-server-state-idle +;; + +(defclass rudel-obby-server-state-idle + (rudel-obby-server-connection-state) + () + "Idle state of a server connection. + +The connection enters this state when all setup work is finished, +the client has joined the session and no operation is in +progress. In this state, the connection waits for new messages +from the client that initiate operations. Simple (which means +stateless in this case) operations are performed without leaving +the idle state.") + +(defmethod rudel-obby/obby_user_colour + ((this rudel-obby-server-state-idle) color-) + "Handle obby 'user_colour' message. +This method is called when the connected user requests a change +of her color to COLOR." + (with-parsed-arguments ((color- color)) + (with-slots (user) (oref this :connection) + (with-slots (color (user-id :user-id)) user + ;; Set color slot value. + (setq color color-) + + ;; Run change hook. + (object-run-hook-with-args user 'change-hook) + + (rudel-broadcast this (list 'exclude (oref this :connection)) + "obby_user_colour" + (format "%x" user-id) + (rudel-obby-format-color color))))) + nil) + +(defmethod rudel-obby/obby_document_create + ((this rudel-obby-server-state-idle) + doc-id name encoding content) + "Handle obby 'document_create' message." + (with-parsed-arguments ((doc-id number) + (encoding coding-system)) + (with-slots (user server) (oref this :connection) + (with-slots ((user-id :user-id)) user + ;; Create a (hidden) buffer for the new document. + (let* ((buffer (get-buffer-create + (generate-new-buffer-name + (concat " *" name "*")))) + ;; Create the new document object + (document (rudel-obby-document + name + :buffer buffer + :subscribed (list user) + :id doc-id + :owner-id user-id + :suffix 1))) + + ;; Initialize the buffer's content + (with-current-buffer buffer + (insert content)) + + (with-slots (suffix) document + ;; Determine an appropriate suffix to provide an unique + ;; name for the new document. + (while (rudel-find-document server + (if (= suffix 1) + name + (format "%s<%d>" name suffix)) + #'string= #'rudel-unique-name) + (incf suffix)) + + ;; Add the document to the server's document list + (rudel-add-document server document) + + ;; Maybe notify the creating client of the changed suffix. + (unless (= suffix 1) + (rudel-send this + "obby_document" + (format "%x %x" user-id doc-id) + "rename" + (format "%x" user-id) + name + (format "%x" suffix))) + + ;; Notify other clients of the new document + (rudel-broadcast this (list 'exclude (oref this :connection)) + "obby_document_create" + (format "%x" user-id) + (format "%x" doc-id) + name + (format "%x" suffix) + (upcase (symbol-name encoding)))) + + ;; Add a jupiter context for (THIS DOCUMENT). + (rudel-add-context server (oref this :connection) document)))) + nil) + ) + +(defmethod rudel-obby/obby_document + ((this rudel-obby-server-state-idle) doc-id action &rest arguments) + "Handle obby 'document' messages." + (with-parsed-arguments ((doc-id document-id)) + ;; Locate the document based on owner id and document id + (let ((document (with-slots (server) (oref this :connection) + (rudel-find-document server doc-id + #'equal #'rudel-both-ids)))) + (rudel-obby-dispatch this action + (append (list document) arguments) + "rudel-obby/obby_document/"))) + ) + +(defmethod rudel-obby/obby_document/subscribe + ((this rudel-obby-server-state-idle) document user-id) + "Handle 'subscribe' submessage of obby 'document' message." + (with-parsed-arguments ((user-id number)) + (let ((user (with-slots (server) (oref this :connection) + (rudel-find-user server user-id + #'= #'rudel-id)))) + (with-slots (owner-id (doc-id :id) subscribed buffer) document + + ;; Track subscription, handle duplicate subscription requests. + (when (memq user subscribed) + (error "User `%s' already subscribed to document `%s'" + (object-name user) (object-name document))) + (rudel-add-user document user) + + ;; Synchronize the buffer content to the client. + (with-current-buffer buffer + ;; Send overall buffer size + (rudel-send this + "obby_document" + (format "%x %x" owner-id doc-id) + "sync_init" + (format "%x" (1- (position-bytes (point-max))))) + + ;; Send buffer chunks with author ids + (dolist (chunk (rudel-chunks document)) + (multiple-value-bind (from to author) chunk + (let ((string (buffer-substring (+ from 1) (+ to 1)))) + (rudel-send this + "obby_document" + (format "%x %x" owner-id doc-id) + "sync_chunk" + string + (format "%x" + (if author + (oref author :user-id) + 0))))))) + + ;; Notify clients of the new subscription (including our own + ;; client, who requested the subscription). + (with-slots ((user-id :user-id)) user + (rudel-broadcast this nil + "obby_document" + (format "%x %x" owner-id doc-id) + "subscribe" + (format "%x" user-id))))) + + ;; Add a jupiter context for (THIS document). + (with-slots (server) (oref this :connection) + (rudel-add-context server (oref this :connection) document)) + nil) + ) + +(defmethod rudel-obby/obby_document/unsubscribe + ((this rudel-obby-server-state-idle) document user-id) + "Handle 'unsubscribe' submessage of 'obby_document' message." + (with-parsed-arguments ((user-id number)) + (let ((user (with-slots (server) (oref this :connection) + (rudel-find-user server user-id + #'= #'rudel-id)))) + (with-slots (owner-id (doc-id :id) subscribed) document + + ;; Track subscription, handle invalid unsubscribe requests + (unless (memq user subscribed) + (error "User `%s' not subscribed to document `%s'" + (object-name user) (object-name document))) + (rudel-remove-user document user) + + ;; Notify clients of the canceled subscription (including our + ;; own client, who requested being unsubscribed). + (with-slots ((user-id :user-id)) user + (rudel-broadcast this nil + "obby_document" + (format "%x %x" owner-id doc-id) + "unsubscribe" + (format "%x" user-id)))) + + ;; Remove jupiter context for (THIS DOCUMENT). + (with-slots (server) (oref this :connection) + (rudel-remove-context server (oref this :connection) document))) + nil) + ) + +(defmethod rudel-obby/obby_document/record + ((this rudel-obby-server-state-idle) + document local-revision remote-revision action &rest arguments) + "Handle 'record' submessages of 'obby_document' message." + (with-parsed-arguments ((local-revision number) + (remote-revision number)) + ;; Dispatch to specialized operation handlers. + (rudel-obby-dispatch + this action + (append (list document local-revision remote-revision) + arguments) + "rudel-obby/obby_document/record/")) + ) + +(defmethod rudel-obby/obby_document/record/ins + ((this rudel-obby-server-state-idle) + document local-revision remote-revision position data) + "Handle 'ins' submessage of 'record' submessages of 'obby_document' message." + (with-parsed-arguments ((position number)) + ;; Construct the operation object and process it. + (rudel-remote-operation + (oref this :connection) document + remote-revision local-revision + (jupiter-insert + (format "insert-%d-%d" + remote-revision local-revision) + :from position + :data data)) + nil) + ) + +(defmethod rudel-obby/obby_document/record/del + ((this rudel-obby-server-state-idle) + document local-revision remote-revision position length) + "Handle 'del' submessage of 'record' submessages of 'obby_document' message." + (with-parsed-arguments ((position number) + (length number)) + ;; Construct the operation object and process it. + (rudel-remote-operation + (oref this :connection) document + remote-revision local-revision + (jupiter-delete + (format "delete-%d-%d" + remote-revision local-revision) + :from position + :to (+ position length))) + nil) + ) + + +;;; Client connection states. +;; + +(defvar rudel-obby-server-connection-states + '((new . rudel-obby-server-state-new) + (encryption-negotiate . rudel-obby-server-state-encryption-negotiate) + (before-join . rudel-obby-server-state-before-join) + (idle . rudel-obby-server-state-idle)) + "Name symbols and classes of connection states.") + + +;;; Class rudel-obby-client +;; + +(defclass rudel-obby-client (rudel-obby-socket-owner + rudel-state-machine) + ((server :initarg :server + :type rudel-obby-server + :documentation + "") + (id :initarg :id + :type integer + :accessor rudel-id + :documentation + "") + (user :initarg :user + :type (or rudel-obby-user null) + :initform nil + :documentation + "") + (encryption :initarg :encryption + :type boolean + :documentation + "")) + "Each object of this class represents one client, that is +connected to the server. This object handles all direct +communication with the client, while broadcast messages are +handled by the server.") + +(defmethod initialize-instance ((this rudel-obby-client) &rest slots) + "Initialize slots of THIS and register state machine states." + ;; Initialize slots of THIS + (when (next-method-p) + (call-next-method)) + + ;; Register states. + (rudel-register-states this rudel-obby-server-connection-states) + ) + +(defmethod rudel-register-state ((this rudel-obby-client) symbol state) + "Register SYMBOL and STATE and set connection slot of STATE." + ;; Associate THIS connection to STATE. + (oset state :connection this) + + ;; Register STATE. + (call-next-method)) + +(defmethod rudel-end ((this rudel-obby-client)) + "" + (rudel-disconnect this)) + +(defmethod rudel-close ((this rudel-obby-client)) + "" + (with-slots (server) this + (rudel-remove-client server this))) + +(defmethod rudel-message ((this rudel-obby-client) message) + "Dispatch MESSAGE to the active state of THIS state machine." + ;; Dispatch message to state + (rudel-accept this message)) + +(defmethod rudel-broadcast ((this rudel-obby-client) + receivers name &rest arguments) + "Broadcast message NAME with arguments ARGUMENTS to RECEIVERS." + (with-slots (server) this + (apply #'rudel-broadcast server receivers name arguments))) + +(defmethod rudel-remote-operation ((this rudel-obby-client) + document + local-revision remote-revision + operation) + "Execute and relay OPERATION on DOCUMENT." + (with-slots (server user) this + ;; Transform OPERATION and find clients that need to receive + ;; notifications. + (let* ((context (rudel-find-context server this document)) + (transformed (jupiter-remote-operation + context + local-revision remote-revision + operation)) + (receivers (rudel-subscribed-clients-not-self + this document))) + + ;; Relay change notification to other clients. We use + ;; TRANSFORMED before the byte -> char conversion which is what + ;; the receivers expect. + (with-slots (user-id) user + (with-slots (owner-id (doc-id :id)) document + ;; Construct and send messages to all receivers individually + ;; since the contents of the messages depends on the state + ;; of the jupiter context associated the respective + ;; receiver. + (dolist (receiver receivers) + + ;; Find the jupiter context for RECEIVER and use its + ;; revision information. + (let ((context (rudel-find-context server receiver document))) + ;; Construct and send one message. + (with-slots (local-revision remote-revision) context + (apply #'rudel-send + receiver + "obby_document" + (format "%x %x" owner-id doc-id) + "record" + (format "%x" user-id) + (format "%x" local-revision) + (format "%x" remote-revision) + (rudel-operation->message transformed))) + + ;; Submit the operation to the jupiter context. + (jupiter-local-operation context transformed))))) + + ;; Incorporate change into DOCUMENT (the server-side + ;; document). We have to convert bytes -> chars before we can do + ;; this. + (with-slots (buffer) document + (rudel-obby-byte->char transformed buffer)) + + (rudel-remote-operation document user transformed))) + ) + +(defmethod rudel-subscribed-clients-not-self ((this rudel-obby-client) + document) + "Return a list of clients subscribed to DOCUMENT excluding THIS." + (with-slots (clients) (oref this :server) + (with-slots (subscribed) document + (remove-if + (lambda (client) + (with-slots (user) client + (or (eq client this) + (not (memq user subscribed))))) + clients))) + ) + + +;;; Class rudel-obby-server +;; + +(defclass rudel-obby-server (rudel-server-session + rudel-socket-owner) + ((clients :initarg :clients + :type list + :initform nil + :documentation + "") + (next-client-id :initarg :next-client-id + :type integer + :initform 1 + :documentation + "") + (next-user-id :initarg :next-user-id + :type integer + :initform 1 + :documentation + "") + (contexts :initarg :contexts + :type hash-table + :documentation + "")) + "Class rudel-obby-server ") + +(defmethod initialize-instance ((this rudel-obby-server) &rest slots) + "" + (when (next-method-p) + (call-next-method)) + + (with-slots (contexts) this + (setq contexts (make-hash-table :test 'equal)))) + +(defmethod rudel-end ((this rudel-obby-server)) + "" + (rudel-disconnect this)) + +(defmethod rudel-broadcast ((this rudel-obby-server) + receivers name &rest arguments) + "Send a message of type NAME with arguments ARGUMENTS to RECEIVERS. + +RECEIVERS can be a object derived from rudel-obby-client, a list +of such objects or a list with car 'exclude and cdr a list of +such objects derived from rudel-obby-client." + ;; Construct list of receivers. + (let ((receiver-list + (cond + ;; If RECEIVERS is nil, the message should be broadcast to + ;; all clients. + ((null receivers) (oref this :clients)) + ;; If RECEIVERS is a (non-empty) list of rudel-obby-client + ;; (or derived) objects, treat it as a list of receivers. + ((and (listp receivers) + (rudel-obby-client-child-p (car receivers))) + receivers) + ;; If RECEIVERS is a (non-empty) list with cdr equal to + ;; 'exclude treat it as a list of receivers to exclude. + ((and (listp receivers) + (eq (car receivers) 'exclude)) + (with-slots (clients) this + (set-difference clients (cdr receivers) + :key #'rudel-id))) + ;; If RECEIVERS is a single rudel-obby-client (or derived) + ;; object, send the message to that client. + ((rudel-obby-client-child-p receivers) + (list receivers)) + ;; + (t (signal 'wrong-type-argument (type-of receivers)))))) + + ;; Send message to receivers. + (dolist (receiver receiver-list) + (apply #'rudel-send receiver name arguments))) + ) + +(defmethod rudel-make-user ((this rudel-obby-server) + name client-id color encryption) + "" + (with-slots (next-user-id) this + (let ((user (rudel-obby-user name + :color color + :client-id client-id + :user-id next-user-id + :connected t + :encryption encryption))) + (incf next-user-id) + user)) + ) + +(defmethod rudel-check-username-and-color ((this rudel-obby-server) + username color) + "Check whether USERNAME and COLOR are valid. +USERNAME must not be empty and must not be used by another +user. COLOR has to be sufficiently different from used colors." + (cond + ;; The empty user name is not allowed + ((string= username "") + rudel-obby-error-username-invalid) + + ;; Make sure the user name is not already in use. + ((rudel-find-user this username + #'string= #'object-name-string) + rudel-obby-error-username-in-use) + + ;; Make sure the color is sufficiently dissimilar to all used + ;; colors. + ((rudel-find-user this color + (lambda (left right) + (< (color-distance left right) 20000)) ;; TODO constant + #'rudel-color) + rudel-obby-error-color-in-use)) + ) + +(defmethod rudel-add-client ((this rudel-obby-server) + client-socket) + "" + (with-slots (next-client-id clients) this + (let ((client (rudel-obby-client (process-name client-socket) + :server this + :socket client-socket + :id next-client-id + :encryption nil))) + (push client clients)) + (incf next-client-id)) + ) + +(defmethod rudel-remove-client ((this rudel-obby-server) + client) + "" + (with-slots ((client-id :id) user) client + ;; Broadcast the part event to all remaining clients. + (rudel-broadcast this (list 'exclude client) + "net6_client_part" + (format "%x" client-id)) + + ;; If the client has an associated user object, set the status of + ;; the user object to offline. + (when user + ;; Set slot value. + (with-slots (connected) user + (setq connected nil)) + + ;; Run change hook. + (object-run-hook-with-args user 'change-hook))) + + (object-remove-from-list this :clients client) + ) + +(defmethod rudel-find-context ((this rudel-obby-server) client document) + "Return the jupiter context associated to (CLIENT DOCUMENT) in THIS." + (with-slots (contexts) this + (gethash (rudel-obby-context-key client document) contexts))) + +(defmethod rudel-add-context ((this rudel-obby-server) client document) + "Add a jupiter context for (CLIENT DOCUMENT) to THIS." + (with-slots (contexts) this + (with-slots ((client-id :id)) client + (with-slots ((doc-name :object-name)) document + (puthash + (rudel-obby-context-key client document) + (jupiter-context (format "%d-%s" client-id doc-name)) + contexts)))) + ) + +(defmethod rudel-remove-context ((this rudel-obby-server) client document) + "Remove the jupiter context associated to (CLIENT DOCUMENT) from THIS." + (with-slots (contexts) this + (remhash + (rudel-obby-context-key client document) + contexts))) + +(defun rudel-obby-context-key (client document) + "Generate hash key based on CLIENT and DOCUMENT." + (with-slots ((client-id :id)) client + (with-slots ((doc-id :id)) document + (list client-id doc-id)))) + +(defmethod object-print ((this rudel-obby-server) &rest strings) + "Print THIS with number of clients." + (with-slots (clients) this + (apply #'call-next-method + this + (format " clients: %d" + (length clients)) + strings)) + ) + +(provide 'rudel-obby-server) +;;; rudel-obby-server.el ends here diff --git a/emacs.d/lisp/rudel/obby/.svn/text-base/rudel-obby-state.el.svn-base b/emacs.d/lisp/rudel/obby/.svn/text-base/rudel-obby-state.el.svn-base new file mode 100644 index 0000000..a190967 --- /dev/null +++ b/emacs.d/lisp/rudel/obby/.svn/text-base/rudel-obby-state.el.svn-base @@ -0,0 +1,169 @@ +;;; rudel-obby-state.el --- Base class for states used in the obby backend +;; +;; Copyright (C) 2009 Jan Moringen +;; +;; Author: Jan Moringen <scymtym@users.sourceforge.net> +;; Keywords: Rudel, obby, state machine +;; X-RCS: $Id:$ +;; +;; This file is part of Rudel. +;; +;; Rudel is free software: you can redistribute it and/or modify it +;; under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. +;; +;; Rudel is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with Rudel. If not, see <http://www.gnu.org/licenses>. + + +;;; Commentary: +;; +;; This file contains a base class for finite state machine states +;; used in the obby backend. + + +;;; History: +;; +;; 0.1 - Initial revision + + +;;; Code: +;; + +(require 'eieio) + +(require 'rudel-util) +(require 'rudel-state-machine) + +(require 'rudel-obby-util) + + +;;; Class rudel-obby-state +;; + +(defclass rudel-obby-state (rudel-state) + ((connection :initarg :connection + :type rudel-obby-socket-owner + :documentation + "Connection object that uses the state.")) + "Base class for state classes used in the obby backend." + :abstract t) + +(defmethod rudel-enter ((this rudel-obby-state)) + "Default behavior is doing nothing when entering a state." + nil) + +(defmethod rudel-leave ((this rudel-obby-state)) + "Default behavior is doing nothing when leaving a state.") + +(defmethod rudel-accept ((this rudel-obby-state) message) + "Dispatch to appropriate handler based on MESSAGE. +Display a warning if no such handler is found." + ;; Try to dispatch to the correct message handler. If there is none, + ;; warn. + (let ((name (car message)) + (arguments (cdr message))) + (condition-case error + ;; Try to dispatch + (rudel-dispatch this "rudel-obby/" name arguments) + ;; Warn if we failed to locate or execute the method. Return nil + ;; in this case, so we remain in the current state. + (rudel-dispatch-error + (progn + (display-warning + '(rudel obby) + (format "%s: no method (%s: %s): `%s/%s'; arguments: %s" + (object-print this) (car error) (cdr error) + "rudel-obby" name arguments) + :debug) + nil)))) + ) + +(defmethod rudel-send ((this rudel-obby-state) &rest args) + "Send ARGS through the connection associated with THIS." + (with-slots (connection) this + (apply #'rudel-send connection args))) + + +;;; Class rudel-obby-client-connection-state +;; + +(defclass rudel-obby-client-connection-state (rudel-obby-state) + () + "Base class for state classes used by obby client connections." + :abstract t) + +(defmethod rudel-obby/net6_ping ((this rudel-obby-client-connection-state)) + "Handle net6 'ping' message." + (rudel-send this "net6_pong") + nil) + + +;;; Class rudel-obby-server-connection-state +;; + +(defclass rudel-obby-server-connection-state (rudel-obby-state) + () + "Base class for server connection states." + :abstract t) + +(defmethod rudel-broadcast ((this rudel-obby-server-connection-state) + receivers name &rest arguments) + "Broadcast message NAME with arguments ARGUMENTS to RECEIVERS." + (with-slots (connection) this + (apply #'rudel-broadcast connection receivers name arguments))) + + +;;; Class rudel-obby-document-handler +;; + +(defclass rudel-obby-document-handler () + () + "Mixin class that provides ability to process submessages of + obby 'document' messages.") + +(defmethod rudel-obby/obby_document + ((this rudel-obby-document-handler) doc-id action &rest arguments) + "Handle obby 'document' message family." + ;; Try to dispatch to the correct message handler. If there is none, + ;; warn. + (with-parsed-arguments ((doc-id document-id)) + ;; Locate the document based on owner id and document id. + (let ((document (with-slots (connection) this + (with-slots (session) connection + (rudel-find-document session doc-id + #'equal #'rudel-both-ids))))) + (if document + (condition-case error + ;; Try to dispatch + (rudel-dispatch this "rudel-obby/obby_document/" action + (cons document arguments)) + ;; Warn if we failed to locate or execute the + ;; method. Return nil in this case, so we remain in the + ;; current state. + (rudel-dispatch-error + (progn + (display-warning + '(rudel obby) + (format "%s: no method (%s: %s): `%s:%s'; arguments: %s" + (object-print this) (car error) (cdr error) + "rudel-obby/obby_document/" action arguments) + :debug) + nil))) + ;; If we did not find the document, warn. + (progn + (display-warning + '(rudel obby) + (format "Document not found: %s" doc-id) + :debug) + nil)))) + ) + +(provide 'rudel-obby-state) +;;; rudel-obby-state.el ends here diff --git a/emacs.d/lisp/rudel/obby/.svn/text-base/rudel-obby-util.el.svn-base b/emacs.d/lisp/rudel/obby/.svn/text-base/rudel-obby-util.el.svn-base new file mode 100644 index 0000000..faefe70 --- /dev/null +++ b/emacs.d/lisp/rudel/obby/.svn/text-base/rudel-obby-util.el.svn-base @@ -0,0 +1,314 @@ +;;; rudel-obby-util.el --- Miscellaneous functions for the Rudel obby backend +;; +;; Copyright (C) 2008, 2009 Jan Moringen +;; +;; Author: Jan Moringen <scymtym@users.sourceforge.net> +;; Keywords: Rudel, obby, backend, miscellaneous +;; X-RCS: $Id:$ +;; +;; This file is part of Rudel. +;; +;; Rudel is free software: you can redistribute it and/or modify it +;; under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. +;; +;; Rudel is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with Rudel. If not, see <http://www.gnu.org/licenses>. + + +;;; Commentary: +;; +;; + + +;;; History: +;; +;; 0.1 - Initial revision. + + +;;; Code: +;; + +(eval-when-compile + (require 'cl)) + +(require 'eieio) + +(require 'rudel) +(require 'rudel-util) + +(require 'jupiter) + + +;;; Class rudel-obby-socket-owner +;; + +(defclass rudel-obby-socket-owner (rudel-socket-owner) + ((buffer :initarg :buffer + :type (or null string) + :initform nil + :documentation + "Stores message fragments until complete messages can +be assembled.")) + "This class adds functions for sending and receiving obby +messages to the base class rudel-socket-owner.") + +(defmethod rudel-send ((this rudel-obby-socket-owner) + name &rest arguments) + "Send obby message NAME with arguments ARGUMENTS through the socket associated to THIS." + (with-slots (socket) this + (rudel-obby-send socket name arguments))) + +(defmethod rudel-receive ((this rudel-obby-socket-owner) data) + "Reassemble lines in DATA received on the socket associated with THIS and call message handler." + ;; Assemble fragmented lines. + (with-slots (buffer) this + (rudel-assemble-line-fragments data buffer)) + + ;; Process all available lines. + (rudel-loop-lines data line + ;; `rudel-message' has to dispatch message to an appropriate + ;; handler. + (let ((message (rudel-obby-parse-message line))) + (rudel-message this message))) + ) + +(defgeneric rudel-message ((this rudel-obby-socket-owner) message) + "Called when a message arrives. +Should be implemented in derived classes.") + + +;;; Message serialization +;; + +(defgeneric rudel-operation->message ((this jupiter-operation)) + "Generate a list obby message components from THIS operation.") + +(defmethod rudel-operation->message ((this jupiter-insert)) + "Serialize THIS insert operation." + (with-slots (from data) this + (list "ins" (format "%x" from) data))) + +(defmethod rudel-operation->message ((this jupiter-delete)) + "Serialize THIS delete operation." + (with-slots (from length) this + (list "del" (format "%x" from) (format "%x" length)))) + +(defmethod rudel-operation->message ((this jupiter-compound)) + "Serialize THIS compound operation." + (with-slots (children) this + (apply #'append + (list "split" ) + (mapcar #'rudel-operation->message children)))) + +(defmethod rudel-operation->message ((this jupiter-nop)) + "Serialize THIS nop operation." + (list "nop")) + +(defun rudel-message->operation (message local-revision remote-revision) + "Construct an operation object from MESSAGE and LOCAL-REVISION and REMOTE-REVISION. +LOCAL-REVISION and REMOTE-REVISION are only used in the +construction of the name of the new operation. " + (let ((type (car message))) + (cond + + ;; Insert operation + ((string= type "ins") + (let ((position-numeric (string-to-number (nth 1 message) 16)) + (data (nth 2 message))) + (jupiter-insert + (format "insert-%d-%d" + remote-revision local-revision) + :from position-numeric + :data data))) + + ;; Delete operation + ((string= type "del") + (let ((position-numeric (string-to-number (nth 1 message) 16)) + (length-numeric (string-to-number (nth 2 message) 16))) + (jupiter-delete + (format "delete-%d-%d" + remote-revision local-revision) + :from position-numeric + :to (+ position-numeric length-numeric)))) + + ;; Compound operation + ((string= type "split") + (let* ((rest (cdr message)) + (offset (position-if + (lambda (item) + (member* item '("ins" "del" "nop") + :test #'string=)) + rest + :start 1)) + (first (subseq rest 0 offset)) + (second (subseq rest offset))) + (jupiter-compound + (format "compound-%d-%d" + remote-revision local-revision) + :children + (list (rudel-message->operation + first local-revision remote-revision) + (rudel-message->operation + second local-revision remote-revision))))) + + ;; No operation + ((string= type "nop") + (jupiter-nop + (format "nop-%d-%d" + remote-revision local-revision))) + + ;; Unknown operation type + (t (error "Unknown document record type: `%s'" type)))) + ) + + +;;; Character <-> byte position conversion +;; + +(defgeneric rudel-obby-char->byte ((this jupiter-operation) buffer) + "Convert character positions and lengths in THIS to bytes.") + +(defmethod rudel-obby-char->byte ((this jupiter-insert) buffer) + "Convert character positions and lengths in THIS insert to bytes." + (with-slots (from) this + (with-current-buffer buffer + (setq from (- (position-bytes (+ from 1)) 1))))) + +(defmethod rudel-obby-char->byte ((this jupiter-delete) buffer) + "Convert character positions and lengths in THIS delete to bytes." + (with-slots (from to length) this + (let ((old-from (+ from 1)) + (old-to (+ to 1))) + (with-current-buffer buffer + (destructuring-bind (change-from change-to string) + rudel-buffer-change-workaround-data + (setq from (- (position-bytes old-from) 1) + length (string-bytes + (substring string + (- old-from change-from) + (- old-to change-from)))))))) + ) + +(defmethod rudel-obby-char->byte ((this jupiter-compound) buffer) + "Convert character positions and lengths in THIS compound to bytes.." + (with-slots (children) this + (mapc + (lambda (child) + (rudel-obby-char->byte child buffer)) + children)) + ) + +(defmethod rudel-obby-char->byte ((this jupiter-nop) buffer) + "Nothing to convert if THIS is a nop.") + +(defgeneric rudel-obby-byte->char ((this jupiter-operation) buffer) + "Convert byte positions and lengths in THIS to character positions.") + +(defmethod rudel-obby-byte->char ((this jupiter-insert) buffer) + "Convert byte positions and lengths in THIS insert to character positions." + (with-slots (from) this + (with-current-buffer buffer + (setq from (- (byte-to-position (+ from 1)) 1))))) + +(defmethod rudel-obby-byte->char ((this jupiter-delete) buffer) + "Convert byte positions and lengths in THIS delete to character positions." + (with-slots (from to length) this + (let ((old-from from) + (old-length length)) + (with-current-buffer buffer + (setq from (- (byte-to-position (+ old-from 1)) 1) + to (- (byte-to-position (+ old-from old-length 1)) 1))))) + ) + +(defmethod rudel-obby-byte->char ((this jupiter-compound) buffer) + "Convert byte positions and lengths in THIS compound to character positions." + (with-slots (children) this + (mapc + (lambda (child) + (rudel-obby-byte->char child buffer)) + children)) + ) + +(defmethod rudel-obby-byte->char ((this jupiter-nop) buffer) + "Nothing to convert if THIS is a nop.") + + +;;; Miscellaneous functions +;; + +(defun rudel-obby-dispatch (object name arguments &optional prefix) + "Call method starting with PREFIX and ending in NAME of OBJECT with ARGUMENTS. +When PREFIX is not specified, \"rudel-obby/\" is used." + ;; Default prefix. + (unless prefix + (setq prefix "rudel-obby/")) + + ;; Construct a matching symbol. + (let ((method (intern-soft (concat prefix name)))) + ;; If we found a suitable method, run it; Otherwise warn and do + ;; nothing. + (unless (and method + (condition-case error + ;; Try to call METHOD. If successful, always + ;; return t. + (progn + (apply method object arguments) + t) + ;; Warn only when the condition is + ;; 'no-method-definition' and refers to METHOD, + ;; otherwise continue unwinding. + (no-method-definition + (if (eq method (cadr error)) + nil + (signal (car error) (cdr error)))))) + (display-warning + '(rudel obby) + (format "%s: in context `%s': no method: `%s'; arguments: %s" + (object-name-string object) prefix name arguments) + :debug))) + ) + +(defmacro with-parsed-arguments (specs &rest forms) + "Execute FORMS with variable bindings according to SPECS. +SPECS is structured as follows: +SPECS ::= (BINDING*) +BINDING ::= (VAR TYPE) +VAR is a symbol and TYPE is one of number, color, document-id and +coding-system." + (declare (indent 1) + (debug (listp &rest form))) + (let ((bindings + (mapcar + (lambda (spec) + (destructuring-bind (var type) spec + (list var + (case type + ;; Number + (number + `(string-to-number ,var 16)) + ;; Color + (color + `(rudel-obby-parse-color ,var)) + ;; Document Id + (document-id + `(mapcar + (lambda (string) + (string-to-number string 16)) + (split-string ,var " " t))) + ;; Coding System + (coding-system + `(rudel-get-coding-system (downcase ,var))))))) + specs))) + `(let (,@bindings) + ,@forms)) + ) + +(provide 'rudel-obby-util) +;;; rudel-obby-util.el ends here diff --git a/emacs.d/lisp/rudel/obby/.svn/text-base/rudel-obby.el.svn-base b/emacs.d/lisp/rudel/obby/.svn/text-base/rudel-obby.el.svn-base new file mode 100644 index 0000000..a09c0d3 --- /dev/null +++ b/emacs.d/lisp/rudel/obby/.svn/text-base/rudel-obby.el.svn-base @@ -0,0 +1,488 @@ +;;; rudel-obby.el --- An obby backend for Rudel +;; +;; Copyright (C) 2008, 2009 Jan Moringen +;; +;; Author: Jan Moringen <scymtym@users.sourceforge.net> +;; Keywords: Rudel, obby, backend, implementation +;; X-RCS: $Id:$ +;; +;; This file is part of Rudel. +;; +;; Rudel is free software: you can redistribute it and/or modify it +;; under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. +;; +;; Rudel is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with Rudel. If not, see <http://www.gnu.org/licenses>. + + +;;; Commentary: +;; +;; This file contains a Rudel protocol backend, which implements the +;; obby protocol (used by the Gobby collaborative editor until version +;; 0.5). + + +;;; History: +;; +;; 0.2 - Refactored client and server to employ state machine. +;; +;; 0.1 - Initial revision. + + +;;; Code: +;; + +(eval-when-compile + (require 'cl)) + +(require 'eieio) + +(require 'rudel) +(require 'rudel-backend) +(require 'rudel-protocol) +(require 'rudel-util) +(require 'rudel-icons) +(require 'rudel-compat) ;; for `read-color' replacement + + +;;; Constants +;; + +(defconst rudel-obby-version '(0 2) + "Version of the obby backend for Rudel.") + +(defconst rudel-obby-protocol-version 8 + "Version of the obby protocol this library understands.") + +(defvar rudel-obby-long-message-threshold 32768 + "Threshold for message size, above which messages are sent in +multiple chunks.") + +(defvar rudel-obby-long-message-chunk-size 16384 + "Chunk size used, when chunking long messages.") + + +;;; Class rudel-obby-backend +;; + +;;;###autoload +(defclass rudel-obby-backend (rudel-protocol-backend) + ((capabilities :initform '(join host + change-color + track-subscriptions))) + "Main class of the Rudel obby backend. Creates obby client +connections and creates obby servers.") + +(defmethod initialize-instance ((this rudel-obby-backend) &rest slots) + "Initialize slots of THIS with SLOTS." + (when (next-method-p) + (call-next-method)) + + (oset this :version rudel-obby-version)) + +(defmethod rudel-ask-connect-info ((this rudel-obby-backend) &optional info) + "Ask user for the information required to connect to an obby server." + ;; Read server host and port. + (let ((host (or (and info (plist-get info :host)) + (read-string "Server: "))) + (port (or (and info (plist-get info :port)) + (read-number "Port: " 6522))) + ;; Read desired username and color + (username (or (and info (plist-get info :username)) + (read-string "Username: " user-login-name))) + (color (or (and info (plist-get info :color)) + (read-color "Color: " t))) + (encryption (if (and info (member :encryption info)) + (plist-get info :encryption) + (y-or-n-p "Use encryption? "))) + (global-password (if (and info (member :global-password info)) + (plist-get info :global-password) + (read-string "Global password: " ""))) + (user-password (if (and info (member :user-password info)) + (plist-get info :user-password) + (read-string "User password: " "")))) + (append (list :host host + :port port + :username username + :color color + :encryption encryption + :global-password (unless (string= global-password "") + global-password) + :user-password (unless (string= user-password "") + user-password)) + info)) + ) + +(defmethod rudel-connect ((this rudel-obby-backend) info) + "Connect to an obby server using the information INFO. +Return the connection object." + ;; Before we start, load the client functionality. + (require 'rudel-obby-client) + + ;; Create the network process + (let* ((session (plist-get info :session)) + (host (plist-get info :host)) + (port (plist-get info :port)) + (encryption (plist-get info :encryption)) + ;; Create the network process + (socket (funcall + (if encryption + (progn + (require 'rudel-tls) + #'rudel-tls-make-process) + #'make-network-process) + :name host + :host host + :service port + ;; Install connection filter to redirect data to + ;; the connection object + :filter #'rudel-filter-dispatch + ;; Install connection sentinel to redirect state + ;; changes to the connection object + :sentinel #'rudel-sentinel-dispatch + ;; Do not start receiving immediately since the + ;; filter function is not yet setup properly. + :stop t)) + (connection (rudel-obby-connection + host + :session session + :socket socket + :info info))) + + ;; Now start receiving and wait until the basic session setup is + ;; complete. + (continue-process socket) + + ;; Wait for the connection to reach one of the states idle, + ;; join-failed and they-finalized. + (condition-case error + (lexical-let ((reporter (make-progress-reporter "Joining "))) + (flet ((display-progress (state) + (cond + ;; For all states, just spin. + ((consp state) + (progress-reporter-force-update + reporter nil (format "Joining (%s)" (car state)))) + + ;; Done + (t + (progress-reporter-force-update reporter nil "Joining ") + (progress-reporter-done reporter))))) + + (rudel-state-wait connection + '(idle) '(join-failed they-finalized) + #'display-progress))) + + (rudel-entered-error-state + (destructuring-bind (symbol . state) (cdr error) + (if (eq (rudel-find-state connection 'join-failed) state) + (with-slots (error-symbol error-data) state + (signal 'rudel-join-error + (append (list error-symbol) error-data))) + (signal 'rudel-join-error nil))))) + + ;; The connection is now usable; return it. + connection) + ) + +(defmethod rudel-ask-host-info ((this rudel-obby-backend)) + "Ask user for information required to host an obby session." + (let ((port (read-number "Port: " 6522))) + (list :port port))) + +(defmethod rudel-host ((this rudel-obby-backend) info) + "Host an obby session using the information INFO. +Return the created server." + ;; Before we start, we load the server functionality. + (require 'rudel-obby-server) + + ;; Create the network process. + (let* ((port (plist-get info :port)) + ;; Make a server socket + (socket (make-network-process + :name "obby-server" + :host "0.0.0.0" + :service port + :server t + :filter #'rudel-filter-dispatch + :sentinel #'rudel-sentinel-dispatch + ;; + :log + (lambda (server-process client-process message) + (let ((server (rudel-process-object server-process))) + (rudel-add-client server client-process))))) + ;; Construct server object. + (server (rudel-obby-server "obby-server" + :backend this + :socket socket))) + + ;; Return the constructed server. + server) + ) + +(defmethod rudel-make-document ((this rudel-obby-backend) + name session) + "Make a new document in SESSION named NAME. +Return the new document." + ;; Find an unused document id and create a document with that id. + (let ((id (rudel-available-document-id this session))) + (with-slots (user-id) (oref session :self) + (rudel-obby-document name + :session session + :id id + :owner-id user-id + :suffix 1))) + ) + +(defmethod rudel-available-document-id ((this rudel-obby-backend) + session) + "Return a document id, which is not in use in SESSION." + ;; Look through some candidates until an unused id is hit. + (let* ((used-ids (with-slots (documents) session + (mapcar 'rudel-id documents))) + (test-ids (number-sequence 0 (length used-ids)))) + (car (sort (set-difference test-ids used-ids) '<))) + ) + + +;;; Class rudel-obby-user +;; + +(defclass rudel-obby-user (rudel-user) + ((client-id :initarg :client-id + :type (or null integer) ;; We allow nil instead of making + :accessor rudel-client-id ;; the slot unbound, to be able to + :initform nil ;; search with test `rudel-client-id + :documentation ;; without headaches + "Id of the client connection, which the user used to log in. +The value is an integer, if the user is connected, and nil +otherwise.") + (user-id :initarg :user-id + :type integer + :accessor rudel-id + :documentation + "") + (connected :initarg :connected + :type boolean + :accessor rudel-connected + :documentation + "") + (encryption :initarg :encryption ;; TODO maybe we should use unbound when the user is not connected + :type boolean + :documentation + "")) + "Class rudel-obby-user ") + +(defmethod eieio-speedbar-description ((this rudel-obby-user)) + "Provide a speedbar description for THIS." + (let ((connected (oref this :connected)) + (encryption (if (slot-boundp this :encryption) + (oref this :encryption) + nil))) + (format "User %s (%s, %s)" (object-name-string this) + (if connected "Online" "Offline") + (if encryption "Encryption" "Plain"))) + ) + +(defmethod eieio-speedbar-object-buttonname ((this rudel-obby-user)) + "Return a string to use as a speedbar button for THIS." + (rudel-display-string this)) + +(defmethod rudel-display-string ((this rudel-obby-user) + &optional use-images align) + "Return a textual representation of THIS for user interface stuff." + (with-slots (connected color) this + (let ((encryption (and (slot-boundp this :encryption) + (oref this :encryption))) + (name-string (call-next-method))) + (concat + ;; Name bit + (cond + ((numberp align) (format (format "%-%ds" align) name-string)) + ((eq align t) (format "%-12s" name-string)) + (t name-string)) + + ;; Connection status bit + (apply + #'propertize + (if connected "c" "-") + 'help-echo (format (if connected + "%s is connected" + "%s is not connected") + name-string) + 'face (list :background color) + (when use-images + (list 'display (if connected + rudel-icon-connected + rudel-icon-disconnected)))) + + ;; Encryption bit + (apply + #'propertize + (if encryption "e" "-") + 'help-echo (format (if encryption + "%s's connection is encrypted" + "%s's connection is not encrypted") + name-string) + 'face (list :background color) + (when use-images + (list 'display (if encryption + rudel-icon-encrypted + rudel-icon-plaintext))))))) + ) + + +;;; Class rudel-obby-document +;; + +(defclass rudel-obby-document (rudel-document) + ((id :initarg :id + :type integer + :accessor rudel-id + :documentation + "The id of this document. +The id has to be unique only with respect to the other documents +owned by the owner.") + (owner-id :initarg :owner-id + :type integer + :documentation + "") + (suffix :initarg :suffix + :type integer + :documentation + "A counter used to distinguish identically named +documents.")) + "Objects of the class rudel-obby-document represent shared +documents in obby sessions.") + +(defmethod rudel-both-ids ((this rudel-obby-document)) + "Return a list consisting of document and owner id of THIS document." + (with-slots ((doc-id :id) owner-id) this + (list owner-id doc-id))) + +(defmethod rudel-unique-name ((this rudel-obby-document)) + "Generate a unique name for THIS based on the name and the suffix." + (with-slots (suffix) this + (concat (when (next-method-p) + (call-next-method)) + (when (> suffix 1) + (format "<%d>" suffix)))) + ) + +(defmethod eieio-speedbar-description ((this rudel-obby-document)) + "Construct a description for from the name of document object THIS." + (format "Document %s" (object-name-string this))) + +(defmethod eieio-speedbar-object-buttonname ((this rudel-obby-document)) + "Return a string to use as a speedbar button for OBJECT." + (with-slots (subscribed) this + (format "%-12s %s" (object-name-string this) + (if subscribed "s" "-"))) + ) + + +;;; Obby message functions +;; + +(defun rudel-obby-replace-in-string (string replacements) + "Replace elements of REPLACEMENTS in STRING. +REPLACEMENTS is a list of conses whose car is the pattern and +whose cdr is the replacement for the pattern." + (let ((result string)) + (dolist (replacement replacements) + (let ((from (car replacement)) + (to (cdr replacement))) + (setq result (replace-regexp-in-string + from to result nil t)))) + result) + ) + +(defun rudel-obby-escape-string (string) + "Replace meta characters in STRING with their escape sequences." + (rudel-obby-replace-in-string + string + '(("\\\\" . "\\b") ("\n" . "\\n") (":" . "\\d"))) + ) + +(defun rudel-obby-unescape-string (string) + "Replace escaped versions of obby meta characters in STRING with the actual meta characters." + (rudel-obby-replace-in-string + string + '(("\\\\n" . "\n") ("\\\\d" . ":") ("\\\\b" . "\\"))) + ) + +(defun rudel-obby-parse-color (color) + "Parse the obby color string COLOR into an Emacs color." + (let* ((color-numeric (string-to-number color 16)) + (color-string (format "#%04X%04X%04X" + (lsh (logand #xff0000 color-numeric) -08) + (lsh (logand #x00ff00 color-numeric) -00) + (lsh (logand #x0000ff color-numeric) 08)))) + color-string) + ) + +(defun rudel-obby-format-color (color) + "Format the Emacs color COLOR as obby color string." + (multiple-value-bind (red green blue) (color-values color) + (format "%02x%02x%02x" (lsh red -8) (lsh green -8) (lsh blue -8)))) + +(defun rudel-obby-assemble-message (name &rest arguments) + "" + (concat (mapconcat + (lambda (part) + (if (and (not (null part)) (stringp part)) + (rudel-obby-escape-string part) + part)) + (cons name arguments) ":") + "\n") + ) + +(defun rudel-obby-parse-message (message) + "Split MESSAGE at `:' and unescape resulting parts. + +The terminating `\n' should be removed from MESSAGE before +calling this function." + (mapcar #'rudel-obby-unescape-string (split-string message ":"))) + +(defun rudel-obby-send (socket name arguments) + "Send an obby message NAME with arguments ARGUMENTS through SOCKET." + ;; First, assemble the message string. + (let ((message (apply #'rudel-obby-assemble-message + name arguments))) + (if (>= (length message) rudel-obby-long-message-threshold) + ;; For huge messages, chunk the message data and transmit the + ;; chunks + (let ((total (/ (length message) + rudel-obby-long-message-chunk-size)) + (current 0) + (reporter (make-progress-reporter "Sending data " 0.0 1.0))) + (rudel-loop-chunks message chunk rudel-obby-long-message-chunk-size + (progress-reporter-update reporter (/ (float current) total)) + (process-send-string socket chunk) + (incf current)) + (progress-reporter-done reporter)) + ;; Send small messages in one chunk + (process-send-string socket message))) + ) + + +;;; Autoloading +;; + +;;;###autoload +(rudel-add-backend (rudel-backend-get-factory 'protocol) + 'obby 'rudel-obby-backend) + +;;;###autoload +(eval-after-load 'rudel-zeroconf + '(rudel-zeroconf-register-service "_lobby._tcp" 'obby)) + +(provide 'rudel-obby) +;;; rudel-obby.el ends here |