summaryrefslogtreecommitdiffstats
path: root/emacs.d/lisp/rudel/obby/rudel-obby.el
blob: a09c0d38679e384649b0ac8804004e918af1ed53 (plain) (blame)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
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