path: root/emacs.d/lisp/rudel/obby/rudel-obby.el

;;; 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