;;; rudel-obby.el --- An obby backend for Rudel  -*- lexical-binding:t -*-
;;
;; Copyright (C) 2008-2010, 2014, 2016 Free Software Foundation, Inc.
;;
;; 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.3 - Support for transports in client code
;;
;; 0.2 - Refactored client and server to employ state machine
;;
;; 0.1 - Initial version


;;; Code:
;;

(require 'cl-lib)
(require 'eieio)

(require 'rudel)
(require 'rudel-backend)
(require 'rudel-transport)
(require 'rudel-protocol)
(require 'rudel-util)
(require 'rudel-icons)
(require 'rudel-interactive) ;; for read functions


;;; Constants
;;

(defconst rudel-obby-version '(0 3)
  "Version of the obby backend for Rudel.")

(defconst rudel-obby-protocol-version 8
  "Version of the obby protocol this library understands.")

(defconst rudel-obby-default-port 6522
  "Default port used by the obby protocol.")

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

;;;###rudel-autoload
(defclass rudel-obby-backend (rudel-protocol-backend)
  ((capabilities :initform '(join host
			     change-color
			     track-subscriptions
			     encrypt)))
  "Main class of the Rudel obby backend. Creates obby client
connections and creates obby servers.")

(cl-defmethod initialize-instance ((this rudel-obby-backend) _slots)
  "Initialize slots of THIS with SLOTS."
  (cl-call-next-method)

  (oset this :version rudel-obby-version))

(cl-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* (;; TODO encryption is also not handled here
	 (encryption        (if (member :encryption info)
				(plist-get info :encryption)
			      (y-or-n-p "Use encryption (Required by Gobby server, not supported by Rudel server)? ")))
	 ;; Read desired username and color
	 (username        (or (plist-get info :username)
			      (rudel-read-user-name)))
	 (color           (or (plist-get info :color)
			      (rudel-read-user-color)))
	 (global-password (if (member :global-password info)
			      (plist-get info :global-password)
			    (rudel-obtain-password
			     'global info "Global password: ")))
	 (user-password   (if (member :user-password info)
			      (plist-get info :user-password)
			    (rudel-obtain-password
			     'user info "User password: "))))
    (append (list :encryption      encryption
		  :username        username
		  :color           color
		  :global-password (unless (string= global-password "")
				     global-password)
		  :user-password   (unless (string= user-password "")
				     user-password))
	    info))
  )

(cl-defmethod rudel-connect ((this rudel-obby-backend) transport
			  info info-callback
			  &optional progress-callback)
  "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)) ;; Just as name
	 ;; (encryption (plist-get info :encryption))
	 (connection (rudel-obby-connection
		      host
		      :session   session
		      :transport transport
		      :info      info)))

    ;; Start the transport and wait until the basic session setup is
    ;; complete.
    (rudel-start transport)

    (rudel-state-wait connection
		      '(waiting-for-join-info)
		      '(we-finalized they-finalize disconnected)
		      progress-callback)

    ;; Wait until we join the session.
    (catch 'connect
      (let ((switch-to (list 'joining info)))
	(while t
	  ;; Request username and/or color when necessary.
	  (unless (and (plist-get info :username)
		       (plist-get info :color))
	    (setq info      (funcall info-callback this info)
		  switch-to (list 'joining info)))

	  ;; Switch connection to specified state to start the login
	  ;; procedure.
	  (when switch-to
	    (apply #'rudel-switch connection switch-to))

	  ;; Wait for the login procedure to succeed or fail.
	  (condition-case error-data
	      ;; When the connection enters state 'idle', the login
	      ;; succeeded; Break out of the while loop then.
	      (progn
		(rudel-state-wait
		 connection
		 '(idle)
		 '(join-failed
		   we-finalized they-finalized disconnected)
		 progress-callback)
		(throw 'connect t))

	    ;; Connection entered error state
	    (rudel-entered-error-state
	     (pcase-let ((`(,symbol . ,state) (cdr error-data)))
	       (if (eq (rudel-find-state connection 'join-failed) state)

		   ;; For the join-failed state, we can extract
		   ;; details and react accordingly.
		   (pcase symbol
		     ;; Error state is 'join-failed'
		     (`join-failed
		      (with-slots (error-symbol error-data) state
			(message "Login error: %s %s."
				 error-symbol error-data)
			(sleep-for 2)
			(pcase error-symbol
			  ;; Invalid username; reset it.
			  (`rudel-obby-invalid-username
			   (setq info      (plist-put info :username nil)
				 switch-to (list 'joining info)))

			  ;; Username already in use; reset it.
			  (`rudel-obby-username-in-use
			   (setq info      (plist-put info :username nil)
				 switch-to (list 'joining info)))

			  ;; Invalid color; reset it.
			  (`rudel-obby-invalid-color
			   (setq info      (plist-put info :color nil)
				 switch-to (list 'joining info)))

			  ;; Color already in use; reset it.
			  (`rudel-obby-color-in-use
			   (setq info      (plist-put info :color nil)
				 switch-to (list 'joining info)))

			  ;; Unknown error TODO should we signal?
			  (_ nil))))

		     ;; Error state is one of {we, they}-finalize
		     ((or `we-finalized `they-finalized)
		      (with-slots (reason) state
			(signal 'rudel-join-error (list reason)))))

		 ;; For all other error states, we just give up.
		 (signal 'rudel-join-error nil))))))))

    ;; The connection is now usable; return it.
    connection))

(cl-defmethod rudel-ask-host-info ((_this rudel-obby-backend)
				&optional info)
  "Ask user for information required to host an obby session."
  ;; Read address and port unless they are already specified in INFO.
  (let ((address (or (plist-get info :address)
		     "0.0.0.0"))
	(port    (or (plist-get info :port)
		     (read-number "Port: " rudel-obby-default-port))))
    (append (list
	     :address address
	     :port    port)
	    info))
  )

(cl-defmethod rudel-host ((_this rudel-obby-backend) listener _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)

  ;; Construct and return the server object.
  (rudel-obby-server
   "obby-server"
   :listener listener))

(cl-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)))
  )

(cl-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 (cl-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 ")

(cl-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")))
  )

(cl-defmethod eieio-speedbar-object-buttonname ((this rudel-obby-user))
  "Return a string to use as a speedbar button for THIS."
  (rudel-display-string this))


;;; 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.")

(cl-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)))

(cl-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 (cl-call-next-method)
	    (when (> suffix 1)
	      (format "<%d>" suffix))))
  )

(cl-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)))

(cl-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."
  (pcase-let ((`(,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-generate-message (name-and-args)
  "Transform NAME and arguments into an obby protocol message.

The resulting message is a string that looks like this:
\"NAME:ARG1:ARG2:...:ARGN\\n\""
  (concat (mapconcat
	   (lambda (part)
	     (if (and (not (null part)) (stringp part)) ;; TODO temp
		 (rudel-obby-escape-string part)
	       part))
	   name-and-args ":")
	  "\n")
  )


;;; Autoloading
;;

;;;###rudel-autoload
(rudel-add-backend (rudel-backend-get-factory 'protocol)
		   'obby 'rudel-obby-backend)

;;;###rudel-autoload
(eval-after-load 'rudel-zeroconf
  '(rudel-zeroconf-register-service "_lobby._tcp"
				    'start-tls 'obby))

(provide 'rudel-obby)

(require 'rudel-obby-display) ;; define `rudel-display-string'; this
			      ;; is a circular dependency

;;; rudel-obby.el ends here