diff options
Diffstat (limited to 'emacs.d/lisp/rudel/obby/rudel-obby-server.el')
-rw-r--r-- | emacs.d/lisp/rudel/obby/rudel-obby-server.el | 798 |
1 files changed, 798 insertions, 0 deletions
diff --git a/emacs.d/lisp/rudel/obby/rudel-obby-server.el b/emacs.d/lisp/rudel/obby/rudel-obby-server.el new file mode 100644 index 0000000..5bf1158 --- /dev/null +++ b/emacs.d/lisp/rudel/obby/rudel-obby-server.el @@ -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 |