edit-server/edit-server.el

   1 ;;; edit-server.el --- server that responds to edit requests from Chrome
   2
   3 ;; Copyright (C) 2009-2011  Alex Bennee
   4 ;; Copyright (C) 2010-2011  Riccardo Murri
   5
   6 ;; Author: Alex Bennee <alex@bennee.com>
   7 ;; Maintainer: Alex Bennee <alex@bennee.com>
   8 ;; Version: 1.10
   9 ;; Homepage: https://github.com/stsquad/emacs_chrome
  10
  11 ;; This file is not part of GNU Emacs.
  12
  13 ;; This file is free software; you can redistribute it and/or modify
  14 ;; it under the terms of the GNU General Public License as published by
  15 ;; the Free Software Foundation; either version 3, or (at your option)
  16 ;; any later version.
  17
  18 ;; This file is distributed in the hope that it will be useful,
  19 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  20 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  21 ;; GNU General Public License for more details.
  22
  23 ;; You should have received a copy of the GNU General Public License
  24 ;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
  25
  26 ;;; Commentary:
  27
  28 ;; This provides an edit server to respond to requests from the Chrome
  29 ;; Emacs Chrome plugin. This is my first attempt at doing something
  30 ;; with sockets in Emacs. I based it on the following examples:
  31 ;;
  32 ;;   http://www.emacswiki.org/emacs/EmacsEchoServer
  33 ;;   http://nullprogram.com/blog/2009/05/17/
  34 ;;
  35 ;; To use it ensure the file is in your load-path and add something
  36 ;; like the following examples to your .emacs:
  37 ;;
  38 ;; To open pages for editing in new buffers in your existing Emacs
  39 ;; instance:
  40 ;;
  41 ;;   (when (require 'edit-server nil t)
  42 ;;     (setq edit-server-new-frame nil)
  43 ;;     (edit-server-start))
  44 ;;
  45 ;; To open pages for editing in new frames using a running emacs
  46 ;; started in --daemon mode:
  47 ;;
  48 ;;   (when (and (require 'edit-server nil t) (daemonp))
  49 ;;     (edit-server-start))
  50 ;;
  51 ;; Buffers are edited in `text-mode' by default; to use a different
  52 ;; major mode, change `edit-server-default-major-mode' or customize
  53 ;; `edit-server-url-major-mode-alist' to specify major modes based
  54 ;; on the remote URL:
  55 ;;
  56 ;;   (setq edit-server-url-major-mode-alist
  57 ;;         '(("github\\.com" . markdown-mode)))
  58 ;;
  59 ;; Alternatively, set the mode in `edit-server-start-hook'.  For
  60 ;; example:
  61 ;;
  62 ;; (add-hook 'edit-server-start-hook
  63 ;;          (lambda ()
  64 ;;            (when (string-match "github.com" (buffer-name))
  65 ;;              (markdown-mode))))
  66
  67
  68 ;;; Code:
  69
  70 ;; uncomment to debug
  71 ;; (setq debug-on-error t)
  72 ;; (setq edebug-all-defs t)
  73
  74 (unless (featurep 'make-network-process)
  75   (error "Incompatible version of [X]Emacs - lacks make-network-process"))
  76
  77 ;;; Customization
  78
  79 (defcustom edit-server-port 9292
  80   "Local port the edit server listens to."
  81   :group 'edit-server
  82   :type 'integer)
  83
  84 (defcustom edit-server-host nil
  85   "If not nil, accept connections from HOST address rather than just
  86 localhost. This may present a security issue."
  87   :group 'edit-server
  88   :type 'boolean)
  89
  90 (defcustom edit-server-verbose nil
  91   "If not nil, log connections and progress also to the echo area."
  92   :group 'edit-server
  93   :type 'boolean)
  94
  95 (defcustom edit-server-done-hook nil
  96   "Hook run when done editing a buffer for the Emacs HTTP edit-server.
  97 Current buffer holds the text that is about to be sent back to the client."
  98   :group 'edit-server
  99   :type 'hook)
 100
 101 (defcustom edit-server-start-hook nil
 102   "Hook run when starting a editing buffer.  Current buffer is
 103 the fully prepared editing buffer.  Use this hook to enable
 104 buffer-specific modes or add key bindings."
 105   :group 'edit-server
 106   :type 'hook)
 107
 108 ;; frame options
 109
 110 (defcustom edit-server-new-frame t
 111   "If not nil, edit each buffer in a new frame (and raise it)."
 112   :group 'edit-server
 113   :type 'boolean)
 114
 115 (defcustom edit-server-new-frame-alist
 116   '((name . "Emacs TEXTAREA")
 117     (width . 80)
 118     (height . 25)
 119     (minibuffer . t)
 120     (menu-bar-lines . t))
 121   "Frame parameters for new frames.  See `default-frame-alist' for examples.
 122 If nil, the new frame will use the existing `default-frame-alist' values."
 123   :group 'edit-server
 124   :type '(repeat (cons :format "%v"
 125                        (symbol :tag "Parameter")
 126                        (sexp :tag "Value"))))
 127
 128 (defcustom edit-server-default-major-mode
 129   'text-mode
 130   "The default major mode to use in editing buffers, if no other
 131 mode is selected by `edit-server-url-major-mode-alist'."
 132   :group 'edit-server
 133   :type 'function)
 134
 135 (defcustom edit-server-url-major-mode-alist
 136   nil
 137   "A-list of patterns and corresponding functions; when the first
 138 pattern is encountered which matches `edit-server-url', the
 139 corresponding function will be called in order to set the desired
 140 major mode. If no pattern matches,
 141 `edit-server-default-major-mode' will be used."
 142   :group 'edit-server
 143   :type '(alist :key-type (string :tag "Regexp")
 144                 :value-type (function :tag "Major mode function")))
 145
 146 (defcustom edit-server-new-frame-mode-line t
 147   "Show the emacs frame's mode-line if set to t; hide if nil."
 148   :group 'edit-server
 149   :type 'boolean)
 150
 151 ;;; Variables
 152
 153 (defconst edit-server-process-buffer-name " *edit-server*"
 154   "Template name of the edit-server process buffers.")
 155
 156 (defconst edit-server-log-buffer-name "*edit-server-log*"
 157   "Template name of the edit-server process buffers.")
 158
 159 (defconst edit-server-edit-buffer-name "TEXTAREA"
 160   "Template name of the edit-server text editing buffers.")
 161
 162 (defvar edit-server-clients ()
 163   "List of all client processes associated with the server process.")
 164
 165 ;; Buffer local variables
 166 ;;
 167 ;; These are all required to associate the edit buffer with the
 168 ;; correct connection to the client and allow for the buffer to be sent
 169 ;; back when ready. They are `permanent-local` to avoid being reset if
 170 ;; the buffer changes major modes.
 171
 172 (defvar edit-server-proc nil
 173   "Network process associated with the current edit.")
 174 (make-variable-buffer-local 'edit-server-proc)
 175 (put 'edit-server-proc 'permanent-local t)
 176
 177 (defvar edit-server-frame nil
 178   "The frame created for a new edit-server process.")
 179 (make-variable-buffer-local 'edit-server-frame)
 180 (put 'edit-server-frame 'permanent-local t)
 181
 182 (defvar edit-server-phase nil
 183   "Symbol indicating the state of the HTTP request parsing.")
 184 (make-variable-buffer-local 'edit-server-phase)
 185 (put 'edit-server-phase 'permanent-local t)
 186
 187 (defvar edit-server-received nil
 188   "Number of bytes received so far in the client buffer.
 189 Depending on the character encoding, may be different from the buffer length.")
 190 (make-variable-buffer-local 'edit-server-received)
 191 (put 'edit-server-received 'permanent-local t)
 192
 193 (defvar edit-server-request nil
 194   "The HTTP request (GET, HEAD, POST) received.")
 195 (make-variable-buffer-local 'edit-server-request)
 196 (put 'edit-server-request 'permanent-local t)
 197
 198 (defvar edit-server-content-length nil
 199   "The value gotten from the HTTP `Content-Length' header.")
 200 (make-variable-buffer-local 'edit-server-content-length)
 201 (put 'edit-server-content-length 'permanent-local t)
 202
 203 (defvar edit-server-url nil
 204   "The value gotten from the HTTP `x-url' header.")
 205 (make-variable-buffer-local 'edit-server-url)
 206 (put 'edit-server-url 'permanent-local t)
 207
 208 ;;; Mode magic
 209 ;;
 210 ;; We want to re-map some of the keys to trigger edit-server-done
 211 ;; instead of the usual emacs like behaviour. However using
 212 ;; local-set-key will affect all buffers of the same mode, hence we
 213 ;; define a special (derived) mode for handling editing of text areas.
 214
 215
 216 (defvar edit-server-edit-mode-map
 217   (let ((map (make-sparse-keymap)))
 218     (define-key map (kbd "C-x C-s") 'edit-server-save)
 219     (define-key map (kbd "C-x #")   'edit-server-done)
 220     (define-key map (kbd "C-c C-c") 'edit-server-done)
 221     (define-key map (kbd "C-x C-c") 'edit-server-abort)
 222     map)
 223   "Keymap for minor mode `edit-server-edit-mode'.
 224
 225 Redefine a few common Emacs keystrokes to functions that can
 226 deal with the response to the edit-server request.
 227
 228 Any of the following keys will close the buffer and send the text
 229 to the HTTP client: C-x #, C-c C-c.
 230
 231 Pressing C-x C-s will save the current state to the kill-ring.
 232
 233 If any of the above isused with a prefix argument, the
 234 unmodified text is sent back instead.")
 235
 236 (define-minor-mode edit-server-edit-mode
 237   "Minor mode enabled on buffers opened by `edit-server-accept'.
 238
 239 Its sole purpose is currently to enable
 240 `edit-server-edit-mode-map', which overrides common keystrokes to
 241 send a response back to the client."
 242   :group 'edit-server
 243   :lighter " EditSrv"
 244   :init-value nil
 245   :keymap edit-server-edit-mode-map)
 246
 247 (defun turn-on-edit-server-edit-mode-if-server ()
 248   "Turn on `edit-server-edit-mode' if in an edit-server buffer."
 249   (when edit-server-proc
 250     (edit-server-edit-mode t)))
 251
 252 (define-globalized-minor-mode global-edit-server-edit-mode
 253   edit-server-edit-mode turn-on-edit-server-edit-mode-if-server)
 254 (global-edit-server-edit-mode t)
 255
 256
 257 ;; Edit Server socket code
 258
 259 (defun edit-server-start (&optional verbose)
 260   "Start the edit server.
 261
 262 If argument VERBOSE is non-nil, logs all server activity to buffer
 263 `*edit-server-log*'.  When called interactivity, a prefix argument
 264 will cause it to be verbose."
 265   (interactive "P")
 266   (if (or (process-status "edit-server")
 267           (null (condition-case err
 268                     (make-network-process
 269                      :name "edit-server"
 270                      :buffer edit-server-process-buffer-name
 271                      :family 'ipv4
 272                      :host (or edit-server-host 'local)
 273                      :service edit-server-port
 274                      :log 'edit-server-accept
 275                      :server t
 276                      :noquery t)
 277                   (file-error nil))))
 278       (message "An edit-server process is already running")
 279     (setq edit-server-clients '())
 280     (if verbose (get-buffer-create edit-server-log-buffer-name))
 281     (edit-server-log nil "Created a new edit-server process")))
 282
 283 (defun edit-server-stop nil
 284   "Stop the edit server"
 285   (interactive)
 286   (while edit-server-clients
 287     (edit-server-kill-client (car edit-server-clients))
 288     (setq edit-server-clients (cdr edit-server-clients)))
 289   (if (process-status "edit-server")
 290       (delete-process "edit-server")
 291     (message "No edit server running"))
 292   (when (get-buffer edit-server-process-buffer-name)
 293     (kill-buffer edit-server-process-buffer-name)))
 294
 295 (defun edit-server-log (proc fmt &rest args)
 296   "If a `*edit-server-log*' buffer exists, write STRING to it.
 297 This is done for logging purposes.  If `edit-server-verbose' is
 298 non-nil, then STRING is also echoed to the message line."
 299   (let ((string (apply 'format fmt args)))
 300     (if edit-server-verbose
 301         (message string))
 302     (if (get-buffer edit-server-log-buffer-name)
 303         (with-current-buffer edit-server-log-buffer-name
 304           (goto-char (point-max))
 305           (insert (current-time-string)
 306                   " "
 307                   (if (processp proc)
 308                       (concat
 309                        (buffer-name (process-buffer proc))
 310                        ": ")
 311                     "") ; nil is not acceptable to 'insert
 312                   string)
 313           (or (bolp) (newline))))))
 314
 315 (defun edit-server-accept (server client msg)
 316   "Accept a new client connection."
 317   (let ((buffer (generate-new-buffer edit-server-process-buffer-name)))
 318     (when (fboundp 'set-buffer-multibyte)
 319       (set-buffer-multibyte t)) ; djb
 320     (buffer-disable-undo buffer)
 321     (set-process-buffer client buffer)
 322     (set-process-filter client 'edit-server-filter)
 323     ;; kill-buffer kills the associated process
 324     (set-process-query-on-exit-flag client nil)
 325     (with-current-buffer buffer
 326       (setq edit-server-phase 'wait
 327             edit-server-received 0
 328             edit-server-request nil))
 329     (setq edit-server-content-length nil
 330           edit-server-url nil))
 331   (add-to-list 'edit-server-clients client)
 332   (edit-server-log client msg))
 333
 334 (defun edit-server-filter (proc string)
 335   "Process data received from the client."
 336   ;; there is no guarantee that data belonging to the same client
 337   ;; request will arrive all in one go; therefore, we must accumulate
 338   ;; data in the buffer and process it in different phases, which
 339   ;; requires us to keep track of the processing state.
 340   (with-current-buffer (process-buffer proc)
 341     (insert string)
 342     (setq edit-server-received
 343           (+ edit-server-received (string-bytes string)))
 344     (when (eq edit-server-phase 'wait)
 345       ;; look for a complete HTTP request string
 346       (save-excursion
 347         (goto-char (point-min))
 348         (when (re-search-forward
 349                "^\\([A-Z]+\\)\\s-+\\(\\S-+\\)\\s-+\\(HTTP/[0-9\.]+\\)\r?\n"
 350                nil t)
 351           (edit-server-log
 352            proc "Got HTTP `%s' request, processing in buffer `%s'..."
 353            (match-string 1) (current-buffer))
 354           (setq edit-server-request (match-string 1))
 355           (setq edit-server-content-length nil)
 356           (setq edit-server-phase 'head))))
 357
 358     (when (eq edit-server-phase 'head)
 359       ;; look for "Content-length" header
 360       (save-excursion
 361         (goto-char (point-min))
 362         (when (re-search-forward "^Content-Length:\\s-+\\([0-9]+\\)" nil t)
 363           (setq edit-server-content-length
 364                 (string-to-number (match-string 1)))))
 365       ;; look for "x-url" header
 366       (save-excursion
 367         (goto-char (point-min))
 368         (when (re-search-forward "^x-url: .*//\\(.*\\)/" nil t)
 369           (setq edit-server-url (match-string 1))))
 370       ;; look for head/body separator
 371       (save-excursion
 372         (goto-char (point-min))
 373         (when (re-search-forward "\\(\r?\n\\)\\{2\\}" nil t)
 374           ;; HTTP headers are pure ASCII (1 char = 1 byte), so we can subtract
 375           ;; the buffer position from the count of received bytes
 376           (setq edit-server-received
 377                 (- edit-server-received (- (match-end 0) (point-min))))
 378           ;; discard headers - keep only HTTP content in buffer
 379           (delete-region (point-min) (match-end 0))
 380           (setq edit-server-phase 'body))))
 381
 382     (when (eq edit-server-phase 'body)
 383       (if (and edit-server-content-length
 384                (> edit-server-content-length edit-server-received))
 385           (edit-server-log proc
 386                            "Received %d bytes of %d ..."
 387                            edit-server-received edit-server-content-length)
 388         ;; all content transferred - process request now
 389         (cond
 390          ((string= edit-server-request "POST")
 391           ;; create editing buffer, and move content to it
 392           (edit-server-create-edit-buffer proc))
 393          (t
 394           ;; send 200 OK response to any other request
 395           (edit-server-send-response proc "edit-server is running.\n" t)))
 396         ;; wait for another connection to arrive
 397         (setq edit-server-received 0)
 398         (setq edit-server-phase 'wait)))))
 399
 400 (defun edit-server-create-frame(buffer)
 401   "Create a frame for the edit server"
 402   (if edit-server-new-frame
 403       (let ((new-frame
 404              (if (memq window-system '(ns mac))
 405                  ;; Aquamacs, Emacs NS, Emacs (experimental) Mac port
 406                  (make-frame edit-server-new-frame-alist)
 407                (make-frame-on-display (getenv "DISPLAY")
 408                                       edit-server-new-frame-alist))))
 409         (unless edit-server-new-frame-mode-line
 410           (setq mode-line-format nil))
 411         (select-frame new-frame)
 412         (when (and (eq window-system 'x)
 413                    (fboundp 'x-send-client-message))
 414           (x-send-client-message nil 0 nil
 415                                  "_NET_ACTIVE_WINDOW" 32
 416                                  '(1 0 0)))
 417         (raise-frame new-frame)
 418         (set-window-buffer (frame-selected-window new-frame) buffer)
 419         new-frame)
 420     (pop-to-buffer buffer)
 421     (raise-frame)
 422     nil))
 423
 424 (defun edit-server-choose-major-mode ()
 425   "Use `edit-server-url-major-mode-alist' to choose a major mode
 426 initialization function based on `edit-server-url', or fall back
 427 to `edit-server-default-major-mode'"
 428   (let ((pairs edit-server-url-major-mode-alist)
 429         (mode edit-server-default-major-mode))
 430     (while pairs
 431       (let ((entry (car pairs)))
 432         (if (string-match (car entry) edit-server-url)
 433             (setq mode (cdr entry)
 434                   pairs nil)
 435           (setq pairs (cdr pairs)))))
 436     (funcall mode)))
 437
 438 (defun edit-server-create-edit-buffer(proc)
 439   "Create an edit buffer, place content in it and save the network
 440         process for the final call back"
 441   (let ((buffer (generate-new-buffer
 442                  (or edit-server-url
 443                      edit-server-edit-buffer-name))))
 444     (with-current-buffer buffer
 445       (when (fboundp 'set-buffer-multibyte)
 446         (set-buffer-multibyte t))) ; djb
 447     (copy-to-buffer buffer (point-min) (point-max))
 448     (with-current-buffer buffer
 449       (setq edit-server-url (with-current-buffer (process-buffer proc) edit-server-url))
 450       (edit-server-choose-major-mode)
 451       ;; Allow `edit-server-start-hook' to override the major mode.
 452       ;; (re)setting the minor mode seems to clear the buffer-local
 453       ;; variables that we depend upon for the response, so call the
 454       ;; hooks early on
 455       (run-hooks 'edit-server-start-hook)
 456       (not-modified)
 457       (add-hook 'kill-buffer-hook 'edit-server-abort* nil t)
 458       (buffer-enable-undo)
 459       (setq edit-server-proc proc
 460             edit-server-frame (edit-server-create-frame buffer))
 461       (edit-server-edit-mode))))
 462
 463 (defun edit-server-send-response (proc &optional body close)
 464   "Send an HTTP 200 OK response back to process PROC.
 465 Optional second argument BODY specifies the response content:
 466     - If nil, the HTTP response will have null content.
 467     - If a string, the string is sent as response content.
 468     - Any other value will cause the contents of the current
 469       buffer to be sent.
 470 If optional third argument CLOSE is non-nil, then process PROC
 471 and its buffer are killed with `edit-server-kill-client'."
 472   (interactive)
 473   (if (processp proc)
 474       (let ((response-header (concat
 475                               "HTTP/1.0 200 OK\n"
 476                               (format "Server: Emacs/%s\n" emacs-version)
 477                               "Date: "
 478                               (format-time-string
 479                                "%a, %d %b %Y %H:%M:%S GMT\n"
 480                                (current-time)))))
 481         (process-send-string proc response-header)
 482         (process-send-string proc "\n")
 483         (cond
 484          ((stringp body)
 485           (process-send-string proc (encode-coding-string body 'utf-8)))
 486          ((not body) nil)
 487          (t
 488           (encode-coding-region (point-min) (point-max) 'utf-8)
 489           (process-send-region proc (point-min) (point-max))))
 490         (process-send-eof proc)
 491         (when close
 492           (edit-server-kill-client proc))
 493         (edit-server-log proc "Editing done, sent HTTP OK response."))
 494     (message "edit-server-send-response: invalid proc (bug?)")))
 495
 496 (defun edit-server-kill-client (proc)
 497   "Kill client process PROC and remove it from the list."
 498   (let ((procbuf (process-buffer proc)))
 499     (delete-process proc)
 500     (when (buffer-live-p procbuf)
 501       (kill-buffer procbuf))
 502     (setq edit-server-clients (delq proc edit-server-clients))))
 503
 504 (defun edit-server-done (&optional abort nokill)
 505   "Finish editing: send HTTP response back, close client and editing buffers.
 506
 507 The current contents of the buffer are sent back to the HTTP
 508 client, unless argument ABORT is non-nil, in which case then the
 509 original text is sent back.
 510 If optional second argument NOKILL is non-nil, then the editing
 511 buffer is not killed.
 512
 513 When called interactively, use prefix arg to abort editing."
 514   (interactive "P")
 515   ;; Do nothing if the connection is closed by the browser (tab killed, etc.)
 516   (unless (eq (process-status edit-server-proc) 'closed)
 517     (let ((buffer (current-buffer))
 518           (proc edit-server-proc)
 519           (procbuf (process-buffer edit-server-proc)))
 520       ;; edit-server-* vars are buffer-local,
 521       ;; so they must be used before issuing kill-buffer
 522       (if abort
 523           ;; send back original content
 524           (with-current-buffer procbuf
 525             (run-hooks 'edit-server-done-hook)
 526             (edit-server-send-response proc t))
 527         ;; send back edited content
 528         (save-restriction
 529           (widen)
 530           (buffer-disable-undo)
 531           ;; ensure any format encoding is done (like longlines)
 532           (dolist (format buffer-file-format)
 533             (format-encode-region (point-min) (point-max) format))
 534           ;; send back
 535           (run-hooks 'edit-server-done-hook)
 536           (edit-server-send-response edit-server-proc t)
 537           ;; restore formats (only useful if we keep the buffer)
 538           (dolist (format buffer-file-format)
 539             (format-decode-region (point-min) (point-max) format))
 540           (buffer-enable-undo)))
 541       (when edit-server-frame
 542         (delete-frame edit-server-frame))
 543       ;; delete-frame may change the current buffer
 544       (unless nokill
 545         (kill-buffer buffer))
 546       (edit-server-kill-client proc))))
 547
 548 ;;
 549 ;; There are a couple of options for handling the save
 550 ;; action. The intent is to preserve data but not finish
 551 ;; editing. There are a couple of approaches that could
 552 ;; be taken:
 553 ;;  a) Use the iterative edit-server option (send a buffer
 554 ;;     back to the client which then returns new request
 555 ;;     to continue the session).
 556 ;;  b) Back-up the edit session to a file
 557 ;;  c) Save the current buffer to the kill-ring
 558 ;;
 559 ;; I've attempted to do a) a couple of times but I keep running
 560 ;; into problems which I think are emacs bugs. So for now I'll
 561 ;; just push the current buffer to the kill-ring.
 562
 563 (defun edit-server-save ()
 564   "Save the current state of the edit buffer."
 565   (interactive)
 566   (save-restriction
 567     (widen)
 568     (buffer-disable-undo)
 569     (copy-region-as-kill (point-min) (point-max))
 570     (buffer-enable-undo)))
 571
 572 (defun edit-server-abort ()
 573   "Discard editing and send the original text back to the browser."
 574   (interactive)
 575   (edit-server-done t))
 576
 577 (defun edit-server-abort* ()
 578   "Discard editing and send the original text back to the browser,
 579 but don't kill the editing buffer."
 580   (interactive)
 581   (edit-server-done t t))
 582
 583 (provide 'edit-server)
 584
 585 ;;; edit-server.el ends here