Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Newer
Older
100755 436 lines (389 sloc) 16.678 kb
df01782 @candera Initial commit
authored
1 ;;
2 ;; Emacs edit-server
3 ;;
4 ;; This provides an edit server to respond to requests from the Chrome
5 ;; Emacs Chrome plugin. This is my first attempt at doing something
6 ;; with sockets in Emacs. I based it on the following examples:
7 ;;
8 ;; http://www.emacswiki.org/emacs/EmacsEchoServer
9 ;; http://nullprogram.com/blog/2009/05/17/
10 ;;
11 ;; To use it ensure the file is in your load-path and add something
12 ;; like the following examples to your .emacs:
13 ;;
14 ;; To open pages for editing in new buffers in your existing Emacs
15 ;; instance:
16 ;;
17 ;; (if (locate-library "edit-server")
18 ;; (progn
19 ;; (require 'edit-server)
20 ;; (setq edit-server-new-frame nil)
21 ;; (edit-server-start)))
22 ;;
23 ;; To open pages for editing in new frames using a running emacs
24 ;; started in --daemon mode:
25 ;;
26 ;; (if (and (daemonp) (locate-library "edit-server"))
27 ;; (progn
28 ;; (require 'edit-server)
29 ;; (edit-server-start)))
30 ;;
31 ;; (C) 2009 Alex Bennee (alex@bennee.com)
32 ;; (C) 2010 Riccardo Murri (riccardo.murri@gmail.com)
33 ;;
34 ;; Licensed under GPLv3
35 ;;
36
37 ;; uncomment to debug
38 ;(setq debug-on-error 't)
39 ;(setq edebug-all-defs 't)
40
41 (if (not (featurep 'make-network-process))
42 (error "Incompatible version of [X]Emacs - lacks make-network-process"))
43
44 ;; Customization
45 (defcustom edit-server-port 9292
46 "Local port the edit server listens to."
47 :group 'edit-server
48 :type 'integer)
49
50 (defcustom edit-server-host nil
51 "If not nil, accept connections from HOST address rather than just
52 localhost. This may present a security issue."
53 :group 'edit-server
54 :type 'boolean)
55
56 (defcustom edit-server-verbose nil
57 "If not nil, log connections and progress also to the echo area."
58 :group 'edit-server
59 :type 'boolean)
60
61 (defcustom edit-server-done-hook nil
62 "Hook run when done editing a buffer for the Emacs HTTP edit-server.
63 Current buffer holds the text that is about to be sent back to the client."
64 :group 'edit-server
65 :type 'hook)
66
67 (defcustom edit-server-start-hook nil
68 "Hook run when starting a editing buffer. Current buffer is
69 the fully prepared editing buffer. Use this hook to enable your
70 favorite minor modes or add key bindings."
71 :group 'edit-server
72 :type 'hook)
73
74 ; frame options
75 (defcustom edit-server-new-frame t
76 "If not nil, edit each buffer in a new frame (and raise it)."
77 :group 'edit-server
78 :type 'boolean)
79
80 (defcustom edit-server-new-frame-alist
81 '((name . "Emacs TEXTAREA")
82 (width . 80)
83 (height . 25)
84 (minibuffer . t)
85 (menu-bar-lines . t))
86 "Frame parameters for new frames. See `default-frame-alist' for examples.
87 If nil, the new frame will use the existing `default-frame-alist' values."
88 :group 'edit-server
89 :type '(repeat (cons :format "%v"
90 (symbol :tag "Parameter")
91 (sexp :tag "Value"))))
92
93 (defcustom edit-server-new-frame-mode-line t
94 "Show the emacs frame's mode-line if set to t; hide if nil."
95 :group 'edit-server
96 :type 'boolean)
97
98 ;; Vars
99 (defconst edit-server-process-buffer-name " *edit-server*"
100 "Template name of the edit-server process buffers.")
101
102 (defconst edit-server-log-buffer-name "*edit-server-log*"
103 "Template name of the edit-server process buffers.")
104
105 (defconst edit-server-edit-buffer-name "TEXTAREA"
106 "Template name of the edit-server text editing buffers.")
107
108 (defvar edit-server-proc 'nil
109 "Network process associated with the current edit, made local when
110 the edit buffer is created")
111
112 (defvar edit-server-frame 'nil
113 "The frame created for a new edit-server process, made local when
114 then edit buffer is created")
115
116 (defvar edit-server-clients '()
117 "List of all client processes associated with the server process.")
118
119 (defvar edit-server-phase nil
120 "Symbol indicating the state of the HTTP request parsing.")
121
122 (defvar edit-server-received nil
123 "Number of bytes received so far in the client buffer.
124 Depending on the character encoding, may be different from the buffer length.")
125
126 (defvar edit-server-request nil
127 "The HTTP request (GET, HEAD, POST) received.")
128
129 (defvar edit-server-content-length nil
130 "The value gotten from the HTTP `Content-Length' header.")
131
132 (defvar edit-server-url nil
133 "The value gotten from the HTTP `x-url' header.")
134
135 ;; Mode magic
136 ;
137 ; We want to re-map some of the keys to trigger edit-server-done
138 ; instead of the usual emacs like behaviour. However using
139 ; local-set-key will affect all buffers of the same mode, hence we
140 ; define a special (derived) mode for handling editing of text areas.
141 ;
142
143 (define-derived-mode edit-server-text-mode text-mode "Edit Server Text Mode"
144 "A derived version of text-mode with a few common Emacs keystrokes
145 rebound to more functions that can deal with the response to the
146 edit-server request.
147
148 Any of the following keys will close the buffer and send the text
149 to the HTTP client: C-x #, C-x C-s, C-c C-c.
150
151 If any of the above isused with a prefix argument, the
152 unmodified text is sent back instead.
153 "
154 :group 'edit-server)
155 (define-key edit-server-text-mode-map (kbd "C-x #") 'edit-server-done)
156 (define-key edit-server-text-mode-map (kbd "C-x C-s") 'edit-server-done)
157 (define-key edit-server-text-mode-map (kbd "C-c C-c") 'edit-server-done)
158 (define-key edit-server-text-mode-map (kbd "C-x C-c") 'edit-server-abort)
159
160
161 ;; Edit Server socket code
162 ;
163
164 (defun edit-server-start (&optional verbose)
165 "Start the edit server.
166
167 If argument VERBOSE is non-nil, logs all server activity to buffer `*edit-server-log*'.
168 When called interactivity, a prefix argument will cause it to be verbose.
169 "
170 (interactive "P")
171 (if (or (process-status "edit-server")
172 (null (condition-case err
173 (make-network-process
174 :name "edit-server"
175 :buffer edit-server-process-buffer-name
176 :family 'ipv4
177 :host (if edit-server-host
178 edit-server-host
179 'local)
180 :service edit-server-port
181 :log 'edit-server-accept
182 :server t
183 :noquery t)
184 (file-error nil))))
185 (message "An edit-server process is already running")
186 (setq edit-server-clients '())
187 (if verbose (get-buffer-create edit-server-log-buffer-name))
188 (edit-server-log nil "Created a new edit-server process")))
189
190 (defun edit-server-stop nil
191 "Stop the edit server"
192 (interactive)
193 (while edit-server-clients
194 (edit-server-kill-client (car edit-server-clients))
195 (setq edit-server-clients (cdr edit-server-clients)))
196 (if (process-status "edit-server")
197 (delete-process "edit-server")
198 (message "No edit server running"))
199 (if (get-buffer edit-server-process-buffer-name)
200 (kill-buffer edit-server-process-buffer-name)))
201
202 (defun edit-server-log (proc fmt &rest args)
203 "If a `*edit-server-log*' buffer exists, write STRING to it for logging purposes.
204 If `edit-server-verbose' is non-nil, then STRING is also echoed to the message line."
205 (let ((string (apply 'format fmt args)))
206 (if edit-server-verbose
207 (message string))
208 (if (get-buffer edit-server-log-buffer-name)
209 (with-current-buffer edit-server-log-buffer-name
210 (goto-char (point-max))
211 (insert (current-time-string)
212 " "
213 (if (processp proc)
214 (concat
215 (buffer-name (process-buffer proc))
216 ": ")
217 "") ; nil is not acceptable to 'insert
218 string)
219 (or (bolp) (newline))))))
220
221 (defun edit-server-accept (server client msg)
222 "Accept a new client connection."
223 (let ((buffer (generate-new-buffer edit-server-process-buffer-name)))
224 (and (fboundp 'set-buffer-multibyte)
225 (set-buffer-multibyte t)) ; djb
226 (buffer-disable-undo buffer)
227 (set-process-buffer client buffer)
228 (set-process-filter client 'edit-server-filter)
229 (set-process-query-on-exit-flag client nil) ; kill-buffer kills the associated process
230 (with-current-buffer buffer
231 (set (make-local-variable 'edit-server-phase) 'wait)
232 (set (make-local-variable 'edit-server-received) 0)
233 (set (make-local-variable 'edit-server-request) nil))
234 (set (make-local-variable 'edit-server-content-length) nil)
235 (set (make-local-variable 'edit-server-url) nil))
236 (add-to-list 'edit-server-clients client)
237 (edit-server-log client msg))
238
239 (defun edit-server-filter (proc string)
240 "Process data received from the client."
241 ;; there is no guarantee that data belonging to the same client
242 ;; request will arrive all in one go; therefore, we must accumulate
243 ;; data in the buffer and process it in different phases, which
244 ;; requires us to keep track of the processing state.
245 (with-current-buffer (process-buffer proc)
246 (insert string)
247 (setq edit-server-received
248 (+ edit-server-received (string-bytes string)))
249 (when (eq edit-server-phase 'wait)
250 ;; look for a complete HTTP request string
251 (save-excursion
252 (goto-char (point-min))
253 (when (re-search-forward "^\\([A-Z]+\\)\\s-+\\(\\S-+\\)\\s-+\\(HTTP/[0-9\.]+\\)\r?\n" nil t)
254 (edit-server-log proc
255 "Got HTTP `%s' request, processing in buffer `%s'..."
256 (match-string 1) (current-buffer))
257 (setq edit-server-request (match-string 1))
258 (setq edit-server-content-length nil)
259 (setq edit-server-phase 'head))))
260
261 (when (eq edit-server-phase 'head)
262 ;; look for "Content-length" header
263 (save-excursion
264 (goto-char (point-min))
265 (when (re-search-forward "^Content-Length:\\s-+\\([0-9]+\\)" nil t)
266 (setq edit-server-content-length (string-to-number (match-string 1)))))
267 ;; look for "x-url" header
268 (save-excursion
269 (goto-char (point-min))
270 (when (re-search-forward "^x-url: .*//\\(.*\\)/" nil t)
271 (setq edit-server-url (match-string 1))))
272 ;; look for head/body separator
273 (save-excursion
274 (goto-char (point-min))
275 (when (re-search-forward "\\(\r?\n\\)\\{2\\}" nil t)
276 ;; HTTP headers are pure ASCII (1 char = 1 byte), so we can subtract
277 ;; the buffer position from the count of received bytes
278 (setq edit-server-received
279 (- edit-server-received (- (match-end 0) (point-min))))
280 ;; discard headers - keep only HTTP content in buffer
281 (delete-region (point-min) (match-end 0))
282 (setq edit-server-phase 'body))))
283
284 (when (eq edit-server-phase 'body)
285 (if (and edit-server-content-length
286 (> edit-server-content-length edit-server-received))
287 (edit-server-log proc
288 "Received %d bytes of %d ..."
289 edit-server-received edit-server-content-length)
290 ;; all content transferred - process request now
291 (cond
292 ((string= edit-server-request "POST")
293 ;; create editing buffer, and move content to it
294 (edit-server-create-edit-buffer proc))
295 (t
296 ;; send 200 OK response to any other request
297 (edit-server-send-response proc "edit-server is running.\n" t)))
298 ;; wait for another connection to arrive
299 (setq edit-server-received 0)
300 (setq edit-server-phase 'wait)))))
301
302 (defun edit-server-create-frame(buffer)
303 "Create a frame for the edit server"
304 (if edit-server-new-frame
305 (let ((new-frame
306 (if (featurep 'aquamacs)
307 (make-frame edit-server-new-frame-alist)
308 (make-frame-on-display (getenv "DISPLAY")
309 edit-server-new-frame-alist))))
310 (if (not edit-server-new-frame-mode-line)
311 (setq mode-line-format nil))
312 (select-frame new-frame)
313 (if (and (eq window-system 'x)
314 (fboundp 'x-send-client-message))
315 (x-send-client-message nil 0 nil
316 "_NET_ACTIVE_WINDOW" 32
317 '(1 0 0)))
318 (raise-frame new-frame)
319 (set-window-buffer (frame-selected-window new-frame) buffer)
320 new-frame)
321 (pop-to-buffer buffer)
322 nil))
323
324 (defun edit-server-create-edit-buffer(proc)
325 "Create an edit buffer, place content in it and save the network
326 process for the final call back"
327 (let ((buffer (generate-new-buffer (if edit-server-url
328 edit-server-url
329 edit-server-edit-buffer-name))))
330 (with-current-buffer buffer
331 (and (fboundp 'set-buffer-multibyte)
332 (set-buffer-multibyte t))) ; djb
333 (copy-to-buffer buffer (point-min) (point-max))
334 (with-current-buffer buffer
335 (not-modified)
336 (edit-server-text-mode)
337 (add-hook 'kill-buffer-hook 'edit-server-abort* nil t)
338 (buffer-enable-undo)
339 (set (make-local-variable 'edit-server-proc) proc)
340 (set (make-local-variable 'edit-server-frame)
341 (edit-server-create-frame buffer))
342 (run-hooks 'edit-server-start-hook))))
343
344 (defun edit-server-send-response (proc &optional body close)
345 "Send an HTTP 200 OK response back to process PROC.
346 Optional second argument BODY specifies the response content:
347 - If nil, the HTTP response will have null content.
348 - If a string, the string is sent as response content.
349 - Any other value will cause the contents of the current
350 buffer to be sent.
351 If optional third argument CLOSE is non-nil, then process PROC
352 and its buffer are killed with `edit-server-kill-client'."
353 (interactive)
354 (if (processp proc)
355 (let ((response-header (concat
356 "HTTP/1.0 200 OK\n"
357 (format "Server: Emacs/%s\n" emacs-version)
358 "Date: "
359 (format-time-string
360 "%a, %d %b %Y %H:%M:%S GMT\n"
361 (current-time)))))
362 (process-send-string proc response-header)
363 (process-send-string proc "\n")
364 (cond
365 ((stringp body) (process-send-string proc body))
366 ((not body) nil)
367 (t (process-send-region proc (point-min) (point-max))))
368 (process-send-eof proc)
369 (if close
370 (edit-server-kill-client proc))
371 (edit-server-log proc "Editing done, sent HTTP OK response."))
372 (message "edit-server-send-response: invalid proc (bug?)")))
373
374 (defun edit-server-kill-client (proc)
375 "Kill client process PROC and remove it from the list."
376 (let ((procbuf (process-buffer proc)))
377 (delete-process proc)
378 (kill-buffer procbuf)
379 (setq edit-server-clients (delq proc edit-server-clients))))
380
381 (defun edit-server-done (&optional abort nokill)
382 "Finish editing: send HTTP response back, close client and editing buffers.
383
384 The current contents of the buffer are sent back to the HTTP
385 client, unless argument ABORT is non-nil, in which case then the
386 original text is sent back.
387 If optional second argument NOKILL is non-nil, then the editing
388 buffer is not killed.
389
390 When called interactively, use prefix arg to abort editing."
391 (interactive "P")
392 ;; Do nothing if the connection is closed by the browser (tab killed, etc.)
393 (unless (eq (process-status edit-server-proc) 'closed)
394 (let ((buffer (current-buffer))
395 (proc edit-server-proc)
396 (procbuf (process-buffer edit-server-proc)))
397 ;; edit-server-* vars are buffer-local, so they must be used before issuing kill-buffer
398 (if abort
399 ;; send back original content
400 (with-current-buffer procbuf
401 (run-hooks 'edit-server-done-hook)
402 (edit-server-send-response proc t))
403 ;; send back edited content
404 (save-restriction
405 (widen)
406 (buffer-disable-undo)
407 ;; ensure any format encoding is done (like longlines)
408 (dolist (format buffer-file-format)
409 (format-encode-region (point-min) (point-max) format))
410 ;; send back
411 (run-hooks 'edit-server-done-hook)
412 (edit-server-send-response edit-server-proc t)
413 ;; restore formats (only useful if we keep the buffer)
414 (dolist (format buffer-file-format)
415 (format-decode-region (point-min) (point-max) format))
416 (buffer-enable-undo)))
417 (if edit-server-frame (delete-frame edit-server-frame))
418 ;; delete-frame may change the current buffer
419 (unless nokill (kill-buffer buffer))
420 (edit-server-kill-client proc))))
421
422 (defun edit-server-abort ()
423 "Discard editing and send the original text back to the browser."
424 (interactive)
425 (edit-server-done t))
426
427 (defun edit-server-abort* ()
428 "Discard editing and send the original text back to the browser,
429 but don't kill the editing buffer."
430 (interactive)
431 (edit-server-done t t))
432
433 (provide 'edit-server)
434
435 ;;; edit-server.el ends here
Something went wrong with that request. Please try again.