X-Git-Url: https://git.hcoop.net/bpt/emacs.git/blobdiff_plain/6e6c82a4e687708d5a7a3887f92db45bd74da276..2a1e24765bc3de7bf72e7117893307f6f6c441be:/lisp/server.el diff --git a/lisp/server.el b/lisp/server.el index 34ac5d7ba2..6d34df351c 100644 --- a/lisp/server.el +++ b/lisp/server.el @@ -81,7 +81,7 @@ ;;; Code: -(eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl-lib)) (defgroup server nil "Emacs running as a server process." @@ -139,6 +139,32 @@ directory residing in a NTFS partition instead." ;;;###autoload (put 'server-auth-dir 'risky-local-variable t) +(defcustom server-auth-key nil + "Server authentication key. + +Normally, the authentication key is randomly generated when the +server starts, which guarantees some level of security. It is +recommended to leave it that way. Using a long-lived shared key +will decrease security (especially since the key is transmitted as +plain text). + +In some situations however, it can be difficult to share randomly +generated passwords with remote hosts (eg. no shared directory), +so you can set the key with this variable and then copy the +server file to the remote host (with possible changes to IP +address and/or port if that applies). + +The key must consist of 64 ASCII printable characters except for +space (this means characters from ! to ~; or from code 33 to 126). + +You can use \\[server-generate-key] to get a random authentication +key." + :group 'server + :type '(choice + (const :tag "Random" nil) + (string :tag "Password")) + :version "24.3") + (defcustom server-raise-frame t "If non-nil, raise frame when switching to a buffer." :group 'server @@ -367,18 +393,27 @@ If CLIENT is non-nil, add a description of it to the logged message." (server-log (format "Status changed to %s: %s" (process-status proc) msg) proc) (server-delete-client proc)) +(defun server--on-display-p (frame display) + (and (equal (frame-parameter frame 'display) display) + ;; Note: TTY frames still get a `display' parameter set to the value of + ;; $DISPLAY. This is useful when running from that tty frame + ;; sub-processes that want to connect to the X server, but that means we + ;; have to be careful here not to be tricked into thinking those frames + ;; are on `display'. + (not (eq (framep frame) t)))) + (defun server-select-display (display) ;; If the current frame is on `display' we're all set. ;; Similarly if we are unable to open frames on other displays, there's ;; nothing more we can do. (unless (or (not (fboundp 'make-frame-on-display)) - (equal (frame-parameter (selected-frame) 'display) display)) + (server--on-display-p (selected-frame) display)) ;; Otherwise, look for an existing frame there and select it. (dolist (frame (frame-list)) - (when (equal (frame-parameter frame 'display) display) + (when (server--on-display-p frame display) (select-frame frame))) ;; If there's no frame on that display yet, create and select one. - (unless (equal (frame-parameter (selected-frame) 'display) display) + (unless (server--on-display-p (selected-frame) display) (let* ((buffer (generate-new-buffer " *server-dummy*")) (frame (make-frame-on-display display @@ -443,11 +478,11 @@ If CLIENT is non-nil, add a description of it to the logged message." See `server-quote-arg' and `server-process-filter'." (replace-regexp-in-string "&." (lambda (s) - (case (aref s 1) + (pcase (aref s 1) (?& "&") (?- "-") (?n "\n") - (t " "))) + (_ " "))) arg t t)) (defun server-quote-arg (arg) @@ -458,7 +493,7 @@ contains a space. See `server-unquote-arg' and `server-process-filter'." (replace-regexp-in-string "[-&\n ]" (lambda (s) - (case (aref s 0) + (pcase (aref s 0) (?& "&&") (?- "&-") (?\n "&n") @@ -479,47 +514,68 @@ Creates the directory if necessary and makes sure: (setq dir (directory-file-name dir)) (let ((attrs (file-attributes dir 'integer))) (unless attrs - (letf (((default-file-modes) ?\700)) (make-directory dir t)) + (cl-letf (((default-file-modes) ?\700)) (make-directory dir t)) (setq attrs (file-attributes dir 'integer))) ;; Check that it's safe for use. (let* ((uid (nth 2 attrs)) (w32 (eq system-type 'windows-nt)) - (safe (catch :safe - (unless (eq t (car attrs)) ; is a dir? - (throw :safe nil)) - (when (and w32 (zerop uid)) ; on FAT32? - (display-warning - 'server - (format "Using `%s' to store Emacs-server authentication files. + (safe (cond + ((not (eq t (car attrs))) nil) ; is a dir? + ((and w32 (zerop uid)) ; on FAT32? + (display-warning + 'server + (format "Using `%s' to store Emacs-server authentication files. Directories on FAT32 filesystems are NOT secure against tampering. See variable `server-auth-dir' for details." - (file-name-as-directory dir)) - :warning) - (throw :safe t)) - (unless (or (= uid (user-uid)) ; is the dir ours? - (and w32 - ;; Files created on Windows by - ;; Administrator (RID=500) have - ;; the Administrators (RID=544) - ;; group recorded as the owner. - (= uid 544) (= (user-uid) 500))) - (throw :safe nil)) - (when w32 ; on NTFS? - (throw :safe t)) - (unless (zerop (logand ?\077 (file-modes dir))) - (throw :safe nil)) - t))) + (file-name-as-directory dir)) + :warning) + t) + ((and (/= uid (user-uid)) ; is the dir ours? + (or (not w32) + ;; Files created on Windows by Administrator + ;; (RID=500) have the Administrators (RID=544) + ;; group recorded as the owner. + (/= uid 544) (/= (user-uid) 500))) + nil) + (w32 t) ; on NTFS? + (t ; else, check permissions + (zerop (logand ?\077 (file-modes dir))))))) (unless safe (error "The directory `%s' is unsafe" dir))))) +(defun server-generate-key () + "Generate and return a random authentication key. +The key is a 64-byte string of random chars in the range `!'..`~'. +If called interactively, also inserts it into current buffer." + (interactive) + (let ((auth-key + (cl-loop repeat 64 + collect (+ 33 (random 94)) into auth + finally return (concat auth)))) + (if (called-interactively-p 'interactive) + (insert auth-key)) + auth-key)) + +(defun server-get-auth-key () + "Return server's authentication key. + +If `server-auth-key' is nil, just call `server-generate-key'. +Otherwise, if `server-auth-key' is a valid key, return it. +If the key is not valid, signal an error." + (if server-auth-key + (if (string-match-p "^[!-~]\\{64\\}$" server-auth-key) + server-auth-key + (error "The key '%s' is invalid" server-auth-key)) + (server-generate-key))) + ;;;###autoload (defun server-start (&optional leave-dead inhibit-prompt) "Allow this Emacs process to be a server for client processes. -This starts a server communications subprocess through which -client \"editors\" can send your editing commands to this Emacs -job. To use the server, set up the program `emacsclient' in the -Emacs distribution as your standard \"editor\". +This starts a server communications subprocess through which client +\"editors\" can send your editing commands to this Emacs job. +To use the server, set up the program `emacsclient' in the Emacs +distribution as your standard \"editor\". Optional argument LEAVE-DEAD (interactively, a prefix arg) means just kill any existing server communications subprocess. @@ -576,11 +632,13 @@ server or call `M-x server-force-delete' to forcibly disconnect it.") (server-ensure-safe-dir server-dir) (when server-process (server-log (message "Restarting server"))) - (letf (((default-file-modes) ?\700)) + (cl-letf (((default-file-modes) ?\700)) (add-hook 'suspend-tty-functions 'server-handle-suspend-tty) (add-hook 'delete-frame-functions 'server-handle-delete-frame) - (add-hook 'kill-buffer-query-functions 'server-kill-buffer-query-function) - (add-hook 'kill-emacs-query-functions 'server-kill-emacs-query-function) + (add-hook 'kill-buffer-query-functions + 'server-kill-buffer-query-function) + (add-hook 'kill-emacs-query-functions + 'server-kill-emacs-query-function) (add-hook 'kill-emacs-hook 'server-force-stop) ;Cleanup upon exit. (setq server-process (apply #'make-network-process @@ -606,13 +664,7 @@ server or call `M-x server-force-delete' to forcibly disconnect it.") (unless server-process (error "Could not start server process")) (process-put server-process :server-file server-file) (when server-use-tcp - (let ((auth-key - (loop - ;; The auth key is a 64-byte string of random chars in the - ;; range `!'..`~'. - repeat 64 - collect (+ 33 (random 94)) into auth - finally return (concat auth)))) + (let ((auth-key (server-get-auth-key))) (process-put server-process :auth-key auth-key) (with-temp-file server-file (set-buffer-multibyte nil) @@ -706,9 +758,29 @@ Server mode runs a process that accepts commands from the (pp v) (let ((text (buffer-substring-no-properties (point-min) (point-max)))) - (server-send-string - proc (format "-print %s\n" - (server-quote-arg text))))))))) + (server-reply-print (server-quote-arg text) proc))))))) + +(defconst server-msg-size 1024 + "Maximum size of a message sent to a client.") + +(defun server-reply-print (qtext proc) + "Send a `-print QTEXT' command to client PROC. +QTEXT must be already quoted. +This handles splitting the command if it would be bigger than +`server-msg-size'." + (let ((prefix "-print ") + part) + (while (> (+ (length qtext) (length prefix) 1) server-msg-size) + ;; We have to split the string + (setq part (substring qtext 0 (- server-msg-size (length prefix) 1))) + ;; Don't split in the middle of a quote sequence + (if (string-match "\\(^\\|[^&]\\)\\(&&\\)+$" part) + ;; There is an uneven number of & at the end + (setq part (substring part 0 -1))) + (setq qtext (substring qtext (length part))) + (server-send-string proc (concat prefix part "\n")) + (setq prefix "-print-nonl ")) + (server-send-string proc (concat prefix qtext "\n")))) (defun server-create-tty-frame (tty type proc) (unless tty @@ -751,10 +823,6 @@ Server mode runs a process that accepts commands from the (select-frame frame) (process-put proc 'frame frame) (process-put proc 'terminal (frame-terminal frame)) - - ;; Display *scratch* by default. - (switch-to-buffer (get-buffer-create "*scratch*") 'norecord) - frame)) (defun server-create-window-system-frame (display nowait proc parent-id @@ -787,9 +855,6 @@ Server mode runs a process that accepts commands from the (select-frame frame) (process-put proc 'frame frame) (process-put proc 'terminal (frame-terminal frame)) - - ;; Display *scratch* by default. - (switch-to-buffer (get-buffer-create "*scratch*") 'norecord) frame))) (defun server-goto-toplevel (proc) @@ -823,7 +888,7 @@ Server mode runs a process that accepts commands from the (process-put proc 'continuation nil) (if continuation (ignore-errors (funcall continuation))))) -(defun* server-process-filter (proc string) +(cl-defun server-process-filter (proc string) "Process a request from the server to edit some files. PROC is the server process. STRING consists of a sequence of commands prefixed by a dash. Some commands have arguments; @@ -911,6 +976,11 @@ The following commands are accepted by the client: Print STRING on stdout. Used to send values returned by -eval. +`-print-nonl STRING' + Print STRING on stdout. Used to continue a + preceding -print command that would be too big to send + in a single message. + `-error DESCRIPTION' Signal an error and delete process PROC. @@ -933,8 +1003,8 @@ The following commands are accepted by the client: ;; receive the error string and shut down on its own. (sit-for 1) (delete-process proc) - ;; We return immediately - (return-from server-process-filter))) + ;; We return immediately. + (cl-return-from server-process-filter))) (let ((prev (process-get proc 'previous-string))) (when prev (setq string (concat prev string)) @@ -953,7 +1023,7 @@ The following commands are accepted by the client: ;; In earlier versions of server.el (where we used an `emacsserver' ;; process), there could be multiple lines. Nowadays this is not ;; supported any more. - (assert (eq (match-end 0) (length string))) + (cl-assert (eq (match-end 0) (length string))) (let ((request (substring string 0 (match-beginning 0))) (coding-system (and (default-value 'enable-multibyte-characters) (or file-name-coding-system @@ -1008,8 +1078,9 @@ The following commands are accepted by the client: ;; -window-system: Open a new X frame. (`"-window-system" - (setq dontkill t) - (setq tty-name 'window-system)) + (if (fboundp 'x-create-frame) + (setq dontkill t + tty-name 'window-system))) ;; -resume: Resume a suspended tty frame. (`"-resume" @@ -1037,7 +1108,8 @@ The following commands are accepted by the client: (setq dontkill t) (pop args-left)) - ;; -tty DEVICE-NAME TYPE: Open a new tty frame at the client. + ;; -tty DEVICE-NAME TYPE: Open a new tty frame. + ;; (But if we see -window-system later, use that.) (`"-tty" (setq tty-name (pop args-left) tty-type (pop args-left) @@ -1094,11 +1166,19 @@ The following commands are accepted by the client: (setq dir (pop args-left)) (if coding-system (setq dir (decode-coding-string dir coding-system))) - (setq dir (command-line-normalize-file-name dir))) + (setq dir (command-line-normalize-file-name dir)) + (process-put proc 'server-client-directory dir)) ;; Unknown command. (arg (error "Unknown command: %s" arg)))) + ;; If both -no-wait and -tty are given with file or sexp + ;; arguments, use an existing frame. + (and nowait + (not (eq tty-name 'window-system)) + (or files commands) + (setq use-current-frame t)) + (setq frame (cond ((and use-current-frame @@ -1148,12 +1228,17 @@ The following commands are accepted by the client: ;; including code that needs to wait. (with-local-quit (condition-case err - (let* ((buffers - (when files - (server-visit-files files proc nowait)))) - + (let ((buffers (server-visit-files files proc nowait))) (mapc 'funcall (nreverse commands)) + ;; If we were told only to open a new client, obey + ;; `initial-buffer-choice' if it specifies a file. + (unless (or files commands) + (if (stringp initial-buffer-choice) + (find-file initial-buffer-choice) + (switch-to-buffer (get-buffer-create "*scratch*") + 'norecord))) + ;; Delete the client if necessary. (cond (nowait @@ -1534,46 +1619,54 @@ only these files will be asked to be saved." Returns the result of the evaluation, or signals an error if it cannot contact the specified server. For example: \(server-eval-at \"server\" '(emacs-pid)) -returns the process ID of the Emacs instance running \"server\". -This function requires the use of TCP sockets. " - (or server-use-tcp - (error "This function requires TCP sockets")) - (let ((auth-file (expand-file-name server server-auth-dir)) - (coding-system-for-read 'binary) - (coding-system-for-write 'binary) - address port secret process) - (unless (file-exists-p auth-file) - (error "No such server definition: %s" auth-file)) +returns the process ID of the Emacs instance running \"server\"." + (let* ((server-dir (if server-use-tcp server-auth-dir server-socket-dir)) + (server-file (expand-file-name server server-dir)) + (coding-system-for-read 'binary) + (coding-system-for-write 'binary) + address port secret process) + (unless (file-exists-p server-file) + (error "No such server: %s" server)) (with-temp-buffer - (insert-file-contents auth-file) - (unless (looking-at "\\([0-9.]+\\):\\([0-9]+\\)") - (error "Invalid auth file")) - (setq address (match-string 1) - port (string-to-number (match-string 2))) - (forward-line 1) - (setq secret (buffer-substring (point) (line-end-position))) - (erase-buffer) - (unless (setq process (open-network-stream "eval-at" (current-buffer) - address port)) - (error "Unable to contact the server")) - (set-process-query-on-exit-flag process nil) - (process-send-string - process - (concat "-auth " secret " -eval " - (replace-regexp-in-string - " " "&_" (format "%S" form)) - "\n")) + (when server-use-tcp + (let ((coding-system-for-read 'no-conversion)) + (insert-file-contents server-file) + (unless (looking-at "\\([0-9.]+\\):\\([0-9]+\\)") + (error "Invalid auth file")) + (setq address (match-string 1) + port (string-to-number (match-string 2))) + (forward-line 1) + (setq secret (buffer-substring (point) (line-end-position))) + (erase-buffer))) + (unless (setq process (make-network-process + :name "eval-at" + :buffer (current-buffer) + :host address + :service (if server-use-tcp port server-file) + :family (if server-use-tcp 'ipv4 'local) + :noquery t)) + (error "Unable to contact the server")) + (if server-use-tcp + (process-send-string process (concat "-auth " secret "\n"))) + (process-send-string process + (concat "-eval " + (server-quote-arg (format "%S" form)) + "\n")) (while (memq (process-status process) '(open run)) (accept-process-output process 0 10)) (goto-char (point-min)) ;; If the result is nil, there's nothing in the buffer. If the ;; result is non-nil, it's after "-print ". - (when (search-forward "\n-print" nil t) - (let ((start (point))) - (while (search-forward "&_" nil t) - (replace-match " " t t)) - (goto-char start) - (read (current-buffer))))))) + (let ((answer "")) + (while (re-search-forward "\n-print\\(-nonl\\)? " nil t) + (setq answer + (concat answer + (buffer-substring (point) + (progn (skip-chars-forward "^\n") + (point)))))) + (if (not (equal answer "")) + (read (decode-coding-string (server-unquote-arg answer) + 'emacs-internal))))))) (provide 'server)