Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
tree: 0040ab860c
Fetching contributors…

Cannot retrieve contributors at this time

386 lines (344 sloc) 13.448 kB
;;; elnode-rle.el --- Remote Lisp Executiion with Elnode -*- lexical-binding: t -*-
;; Copyright (C) 2012 Nic Ferrier
;; Author: Nic Ferrier
;; Keywords: lisp, hypermedia, processes
;; This program 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.
;; This program 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 this program. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;;
;; This is an elnode handler and tools for doing asynchrous
;; programming.
;;
;; The idea is that you can setup associated child processes and pass
;; them work to do and receive their output over HTTP.
;;; Code:
(require 'elnode)
(require 'web)
(require 'loadhist)
(require 'server)
(defun elnode-rle--handler (httpcon)
"Remote Lisp Evaluator handler.
This can be spawned in a client to allow any lisp code to be
passed over the client-server link."
(let* ((lisp-to-run (elnode-http-param httpcon "lisp"))
(lisp
(if lisp-to-run
(car (read-from-string lisp-to-run))))
(bindings-to-use (elnode-http-param httpcon "bindings"))
(bindings
(if bindings-to-use
(car (read-from-string bindings-to-use))))
(to-eval (list 'let bindings lisp)))
(elnode-http-start httpcon 200 '("Content-type" . "text/plain"))
(let ((nomessage t))
(with-stdout-to-elnode httpcon
(eval to-eval)))))
(ert-deftest elnode-rle--handler ()
"Test the Remote Lisp Evaluator handler."
(flet ((lisp-encode (param lisp)
(cons param (format "%S" lisp)))
(do-test (lisp bindings)
(fakir-mock-process
:httpcon
((:elnode-http-params (list lisp bindings)))
(elnode-rle--handler :httpcon)
(with-current-buffer (process-buffer :httpcon)
(goto-char (point-min))
;; Find the header end.
(re-search-forward "\r\n\r\n" nil 't)
(buffer-substring (point) (point-max))))))
(should
(equal
;; Match the content transfer encoded
"c\r\nhello world!\r\n0\r\n\r\n"
(let*
((lisp (lisp-encode
"lisp" '(let ((a "hello world!")) (princ a))))
(bindings (lisp-encode
"bindings" '((a 10)(b 20)))))
(do-test lisp bindings))))
(should
(equal
"2\r\n30\r\n0\r\n\r\n"
(let*
((lisp (lisp-encode
"lisp" '(let ((a (+ b 10))) (princ a))))
(bindings (lisp-encode
"bindings" '((a 10)(b 20)))))
(do-test lisp bindings))))))
(defvar elnode-rle--servers (make-hash-table :test 'equal)
"The hash of RLE servers available.")
(defun elnode-rle--load-path-ize (lisp)
"Wrap LISP in the current load-path."
(concat
;; There is a very strange thing with sending lisp to
;; (read) over a piped stream... (read) can't cope with
;; multiple lines; so we encode newline here.
;;(replace-regexp-in-string
;; "\n"
;; "\\\\n"
(format "(progn (setq load-path (quote %S)) %s)"
(append (list default-directory) load-path)
lisp)))
(defun elnode-rle--handler-lisp (to-require)
"Return a file with Lisp to start Elnode with TO-REQUIRE.
Used to construct the lisp to send. You're unlikely to need to
override this at all, the function is just here to make the
implementation easier to debug.
TO-REQUIRE is a list of things to require, currently only 1 is
allowed."
(let ((temp-file
(make-temp-file
(format "elnode-rle-%s" (symbol-name to-require)))))
(with-temp-file temp-file
(insert
(elnode-rle--load-path-ize
(format "(progn
(setq elnode-do-init nil)
(setq elnode--do-error-logging nil)
(require (quote %s))
(require (quote elnode-rle))
(toggle-debug-on-error)
(setq elnode-rle-port (elnode-find-free-service))
(elnode-start 'elnode-rle--handler :port elnode-rle-port)
(print (format \"\\nelnode-port=%%d\\n\" port)))"
to-require))))
temp-file))
(defun elnode-rle--httpcon-mapper (client-header
client-data
elnode-httpcon
&optional end-callback)
"Elnode specific client connection to HTTP connection mapper.
Maps client async data responses to an elnode server response."
(unless (process-get elnode-httpcon :elnode-rle-header-sent)
(elnode-http-start
elnode-httpcon
(gethash 'status-code client-header))
(process-put elnode-httpcon :elnode-rle-header-sent t))
(if (eq client-data :done)
(elnode-http-return elnode-httpcon) ; return if we're done
;; Else just send the data
(elnode-http-send-string elnode-httpcon client-data)))
(defun elnode-rle--client-data-mapper (con header data stream end-callback)
"Recevies data from the RLE server and sends it to the STREAM.
END-CALLBACK is to be called when the client sees EOF."
(cond
((processp stream) ; this should really elnode-http-p
(elnode-rle--httpcon-mapper header data stream end-callback))
((bufferp stream)
(if (not (eq data :done))
(with-current-buffer stream
(save-excursion
(goto-char (point-max))
(insert data)))
;; Process is done.
(and (functionp end-callback)
(funcall end-callback header))))))
(defun elnode-rle--call-mapper (data-to-send stream port
&optional end-callback)
"Make a client call to PORT mapping response to STREAM.
When it finishes, call END-CALLBACK, if present, with the header."
(web-http-post
(lambda (con header data)
(elnode-rle--client-data-mapper
con
header
data
stream
end-callback))
"/"
:host "localhost"
:port port
:data data-to-send
:mime-type "application/x-elnode"
:mode 'stream))
(defun elnode-rle--make-server (to-require)
"Make an RLE server, a child Emacs running the RLE handler.
Return a proc that represents the child process. The child
process has a property `:exec' which is a function that calls the
RLE handler in the child's Elnode server (waiting for the server
to start first and provide the relevant port) by calling
`elnode-rle-call-mapper' with the stream from the `:exec' call
and the child's remote HTTP port.
The `:exec' proc will signal `elnode-rle-child-port' if the child
server does not start properly." ; yes. I know it's bloody complicated.
(let* ((proc-buffer
(get-buffer-create
(format "* %s *" "thingy")))
(emacsrun
"/usr/bin/emacs -Q --daemon=elnode-debugit")
(proc
(start-process-shell-command
"elnode-rle-server"
proc-buffer
emacsrun))
(file-of-lisp
(elnode-rle--handler-lisp
to-require)))
;; Start elnode in it
(server-eval-at "elnode-debugit" `(load-file ,file-of-lisp))
(process-put proc :daemonhandle "elnode-debugit")
(process-put
proc
:port
(server-eval-at
(process-get proc :daemonhandle)
'elnode-rle-port))
;; Collect the port from the remote Emacs
;; - FIXME this should also collect the secure token
(set-process-filter
proc
(lambda (proc data)
;; Optional delay for test reasons
(with-current-buffer (process-buffer proc)
(save-excursion
(goto-char (point-max))
(insert data)))))
;; Make a handler to call the server
(process-put
proc :exec
(lambda (data stream &optional end-callback)
(let ((ephemeral-port (process-get proc :port)))
(elnode-rle--call-mapper data stream ephemeral-port end-callback))))
proc))
(defun elnode-rle--sender (stream to-require bindings body
&optional end-callback)
"Make a call using a client to the RLE server elsewhere.
The RLE server is reused over TO-REQUIRE, if it's not already
existing, it is created."
(let ((server (gethash to-require elnode-rle--servers)))
;; Make the server if we don't have it
(unless server
(setq server
(puthash to-require
(elnode-rle--make-server (car to-require))
elnode-rle--servers)))
;; Now make the call to the server
(let ((data (make-hash-table :test 'equal)))
(puthash "bindings" (format "%S" bindings) data)
(puthash "lisp" (format "%S" body) data)
(let ((client-connection
(funcall
(process-get server :exec)
data
stream
end-callback)))
;; If we're streaming to elnode then we need to mark the connection
(when (processp stream)
(process-put
stream
:elnode-child-process
client-connection))))))
(defvar elnode-rle--async-do-end-callback nil
"Used by `elnode-async-do' as the source of an end-callback.
This is just used by tests for end signalling.")
(defmacro elnode-async-do (stream
requires requirements
with-environment bindings
do &rest body)
"Execute the BODY in a remote Emacs.
The STREAM is used to handle any output.
The REQUIREMENTS is a list of provide symbol names that will be
used to establish the right environment in the remote.
The BINDINGS are also sent to the remote.
TODO
security for the remote using the stored key."
(assert (eq with-environment 'with-environment))
(assert (eq requires 'requires))
(assert (eq do 'do))
(let ((bodyv (make-symbol "body"))
(bindsv (make-symbol "binds"))
(streamv (make-symbol "streamv"))
(requirev (make-symbol "providing")))
`(let* ((,streamv ,stream)
(,bodyv (quote (progn ,@body)))
(,bindsv (list
,@(loop for p in bindings
collect
(if (and p (listp p))
(list 'list `(quote ,(car p)) (cadr p))
(list 'cons `,p nil)))))
(,requirev (quote ,requirements)))
(elnode-rle--sender
,streamv ,requirev ,bindsv ,bodyv
elnode-rle--async-do-end-callback))))
(defmacro with-elnode-rle-wait (&rest body)
"Simplify the wait for RLE; for testers."
`(unwind-protect
(let (ended)
(progn
,@body)
(while (not ended) (sit-for 1)))
;; FIXME - can we get to the name of this?
(server-eval-at "elnode-debugit" '(kill-emacs))))
(ert-deftest elnode-rle--make-server ()
"Test making an RLE server.
Do it all 3 ways: directly with the `elnode-rle-make-server',
with the `elnode-rle--sender' function and finally with the user
facing macro `elnode-async-do'.
The output from the RLE call is collected in a buffer
and tested."
(flet ((make-hash (bindings)
(let ((h (make-hash-table :test 'equal)))
(loop for b in bindings
do (puthash (car b) (cadr b) h))
h)))
;; Do it RAW
(should
(equal
"hello"
(with-temp-buffer
(let* ((child-proc (elnode-rle--make-server 'elnode))
(daemon-handler (process-get child-proc :daemonhandle))
(collect-buf (current-buffer)))
(with-elnode-rle-wait
(funcall
(process-get child-proc :exec)
(make-hash '(("bindings" "((a \"hello\"))")
("lisp" "(princ \"hello\")")))
(current-buffer)
(lambda (hdr) ; the end proc
(setq ended t))))
(buffer-substring (point-min) (point-max))))))
;; Do it via the sender func
(should
(equal
"40"
(with-temp-buffer
(with-elnode-rle-wait
(let ((elnode-rle--servers (make-hash-table :test 'equal)))
(elnode-rle--sender
(current-buffer)
'(elnode)
'((a 10) (b 20))
'(let ((c 30))(princ (+ c a)))
(lambda (header)
(message "elnode-rle: all done!")(setq ended t)))))
(buffer-substring (point-min) (point-max)))))
;; Do it with the macro
(should
(equal
"hello"
(with-temp-buffer
(with-elnode-rle-wait
(let ((elnode-rle--servers (make-hash-table :test 'equal))
(elnode-rle--async-do-end-callback
(lambda (header)
(message "elnode-rle: in the dyn bound callback!")
(setq ended t))))
(elnode-async-do
(current-buffer)
requires (elnode enode-rle)
with-environment ((a 10)(b 20))
do (princ "hello"))))
(buffer-substring (point-min) (point-max)))))))
(provide 'elnode-rle)
;; elnode-rle ends here
Jump to Line
Something went wrong with that request. Please try again.