branch: externals/futur
commit a68287d8bfd24d88bba9dafc0b770b6f3b0cc159
Author: Stefan Monnier <[email protected]>
Commit: Stefan Monnier <[email protected]>
Add support to run code in Bubblewrap sandbox
* futur-client.el (futur--elisp-servers): Make it an alist.
(futur--elisp-process-filter, futur--elisp-process-sentinel):
Adjust accordingly.
(futur--elisp-process-sentinel): If a futur was waiting for an answer,
deliver a failure.
(futur--elisp-launch): Add `kind` and `prefix` arguments.
Remember the last time of the process's activity.
(futur--elisp-get-process): Add `kind` and `launcher` arguments.
(futur--elisp-funcall-1): Extact from `futur--elisp-funcall`.
Fix handling of input that includes CR bytes.
Remember the last time of the process's activity.
Slightly improve error handling.
(futur--elisp-funcall): Use it.
(futur--bwrap-args, futur--sandbox-ro-dirs): New vars.
(futur--sandbox-launch, futur--sandbox-funcall): New functions.
* futur-server.el (futur-reset-context): Rename from `futur--obarray`.
(futur-server-call-in-context): Delete function.
* futur-tests.el (futur-elisp-funcall): Test transfer of strings
with control chars.
(futur-sandbox-funcall): New test.
---
futur-client.el | 98 ++++++++++++++++++++++++++++++++++++++++++++++-----------
futur-server.el | 20 +++++++++---
futur-tests.el | 68 ++++++++++++++++++++++++++++++++-------
futur.el | 4 +++
4 files changed, 156 insertions(+), 34 deletions(-)
diff --git a/futur-client.el b/futur-client.el
index 34920ec45f..a34ac39de7 100644
--- a/futur-client.el
+++ b/futur-client.el
@@ -34,10 +34,14 @@
"String that will necessarily cause `read' to signal an error.
This has to be the same used by `futur-server'.")
-(defvar futur--elisp-servers nil)
+(defvar futur--elisp-servers nil
+ "Alist mapping server kinds to lists of processes.
+A server kind is a symbol.")
(defun futur--elisp-process-filter (proc string)
- (cl-assert (memq proc futur--elisp-servers))
+ (cl-assert (process-get proc 'futur--kind))
+ (cl-assert (memq proc (assq (process-get proc 'futur--kind)
+ futur--elisp-servers)))
(let ((pending (process-get proc 'futur--pending))
(case-fold-search nil))
(process-put proc 'futur--pending nil)
@@ -123,21 +127,28 @@ This has to be the same used by `futur-server'.")
tail)))))
(defun futur--elisp-process-sentinel (proc status)
- (if (futur--process-completed-p proc)
- (setq futur--elisp-servers (delq proc futur--elisp-servers))
- (message "futur--elisp-process-sentinel before end: %S" status)))
+ (let* ((proclist (assq (process-get proc 'futur--kind)
+ futur--elisp-servers)))
+ (cl-assert (memq proc (cdr proclist)))
+ (if (not (futur--process-completed-p proc))
+ (message "futur--elisp-process-sentinel before end: %S" status)
+ (cl-callf (lambda (ps) (delq proc ps)) (cdr proclist))
+ (let ((futur (process-get proc 'futur--destination)))
+ (when futur
+ (process-put proc 'futur--destination nil)
+ (futur-deliver-failure futur (list 'error "Futur-server died")))))))
-(defun futur--elisp-launch ()
- (let* ((buffer (get-buffer-create " *futur-server*"))
+(defun futur--elisp-launch (kind &optional prefix)
+ (let* ((buffer (get-buffer-create (format" *%s*" kind)))
(stderr (make-pipe-process
- :name "futur-server-stderr"
+ :name (format "%s-stderr" kind)
:noquery t
:coding 'emacs-internal
:buffer buffer
:filter #'futur--elisp-process-filter-stderr
:sentinel #'ignore))
(proc (make-process
- :name "futur-server"
+ :name (symbol-name kind)
:noquery t
:buffer buffer
:connection-type 'pipe
@@ -146,13 +157,16 @@ This has to be the same used by `futur-server'.")
:filter #'futur--elisp-process-filter
:sentinel #'futur--elisp-process-sentinel
:command
- `(,(expand-file-name invocation-name invocation-directory)
+ `(,@prefix
+ ,(expand-file-name invocation-name invocation-directory)
"-Q" "--batch"
"-l" ,(locate-library "futur-server")
"-f" "futur-server"))))
+ (process-put proc 'futur--kind kind)
(process-put proc 'futur--state :booting)
(process-put proc 'futur--rid 0)
- (push proc futur--elisp-servers)
+ (process-put proc 'futur--last-time (float-time))
+ (push proc (alist-get kind futur--elisp-servers))
proc))
(defun futur--elisp-process-answer (proc sexp-string)
@@ -189,12 +203,12 @@ This has to be the same used by `futur-server'.")
;; `(futur-server . ,proc)
nil)))
-(defun futur--elisp-get-process ()
+(defun futur--elisp-get-process (kind launcher)
(let ((ready (seq-find (lambda (proc) (process-get proc 'futur--ready))
- futur--elisp-servers)))
+ (alist-get kind futur--elisp-servers))))
(if ready (futur-done ready)
(futur-let*
- ((proc (futur--elisp-launch))
+ ((proc (funcall launcher kind))
(answer <- (futur--elisp-answer-futur proc)))
(if (eq answer :ready)
(progn
@@ -209,13 +223,14 @@ This has to be the same used by `futur-server'.")
;; (cl-defmethod futur-blocker-wait ((blocker (head futur-server)))
;; (while ?? (accept-process-output proc ...)))
-(defun futur--elisp-funcall (func &rest args)
+(defun futur--elisp-funcall-1 (futur-proc func args)
(futur-let*
- ((proc <- (futur--elisp-get-process))
+ ((proc <- futur-proc)
(rid (cl-incf (process-get proc 'futur--rid)))
(_ (with-temp-buffer
;; (trace-values :funcall rid func args)
(process-put proc 'futur--ready nil)
+ (process-put proc 'futur--last-time (float-time))
(let ((print-length nil)
(print-level nil)
(coding-system-for-write 'emacs-internal)
@@ -225,6 +240,8 @@ This has to be the same used by `futur-server'.")
;; works only on single-lines, so it's super-important
;; we don't include any LF by accident.
(print-escape-newlines t)
+ ;; Not only LF but also CR terminates the single line :-(
+ (print-escape-control-characters t)
;; SWP aren't currently printed in a `read'able way, so we
may
;; as well print them bare.
(print-symbols-bare t))
@@ -237,16 +254,61 @@ This has to be the same used by `futur-server'.")
)))
(read-answer <- (futur--elisp-answer-futur proc)))
;; (trace-values :read-answer read-answer)
- (pcase-exhaustive read-answer
+ (pcase read-answer
(`(:read-success ,(pred (equal rid)))
(futur-let* ((call-answer <- (futur--elisp-answer-futur proc)))
(pcase-exhaustive call-answer
(`(:funcall-success ,(pred (equal rid)) . ,val)
(process-put proc 'futur--ready t)
+ (process-put proc 'futur--last-time (float-time))
val)
(`(:funcall-error ,(pred (equal rid)) . ,err)
(process-put proc 'futur--ready t)
- (futur--resignal err))))))))
+ (process-put proc 'futur--last-time (float-time))
+ (futur--resignal err)))))
+ (`(:read-success . ,_)
+ ;; (futur--funcall #'futur--client-resync proc)
+ (error "Out-of-order reply: %S" read-answer))
+ (_
+ ;; (futur--funcall #'futur--client-resync proc)
+ (error "futur-server error: %S" read-answer)))))
+
+(defun futur--elisp-funcall (func &rest args)
+ (futur--elisp-funcall-1
+ (futur--elisp-get-process 'futur-server #'futur--elisp-launch)
+ func args))
+
+;;;; Running in a sandbox
+
+;; Inspired by the code in `elpa-admin.el'.
+
+(defconst futur--bwrap-args
+ '("--unshare-all"
+ "--dev" "/dev"
+ "--proc" "/proc"
+ "--tmpfs" "/tmp"))
+
+(defvar futur--sandbox-ro-dirs
+ '("/lib" "/lib64" "/bin" "/usr" "/etc/alternatives" "/etc/emacs" "/gnu"
"~/"))
+
+(defun futur--sandbox-launch (kind)
+ ;; Don't inherit MAKEFLAGS from any surrounding make process,
+ ;; nor TMP/TMPDIR since the container uses its own tmp dir.
+ (let ((process-environment `("MAKEFLAGS" "TMP" "TMPDIR"
+ ,@process-environment)))
+ (futur--elisp-launch
+ kind `("bwrap"
+ ,@futur--bwrap-args
+ ,@(mapcan (lambda (dir)
+ (when (file-directory-p dir)
+ (let ((dir (expand-file-name dir)))
+ `("--ro-bind" ,dir ,dir))))
+ futur--sandbox-ro-dirs)))))
+
+(defun futur--sandbox-funcall (func &rest args)
+ (futur--elisp-funcall-1
+ (futur--elisp-get-process 'futur-sandbox #'futur--sandbox-launch)
+ func args))
(provide 'futur-client)
;;; futur-client.el ends here
diff --git a/futur-server.el b/futur-server.el
index dc6f992e04..2f884b97af 100644
--- a/futur-server.el
+++ b/futur-server.el
@@ -120,11 +120,21 @@ Does not pay attention to buffer-local values of
variables."
(setq other-list (cdr other-list)))
(null prefix))
-(defalias 'futur--obarray
+(defalias 'futur-reset-context
;; Store the snapshots inside the closure rather than in a global
;; variable, so that `futur--obarray-revert' doesn't undo it.
(let ((snapshots '()))
(lambda (name target)
+ "Reset vars and functions to a known state.
+NAME is the name chosen for that state.
+TARGET is the description of the context. It should be a list
+of elements that can be:
+- A file name that should be `load'ed.
+- A feature that shoujd be `require'd.
+- A function that should be called.
+The elements are processed in order, starting from the state at startup.
+NAME is used only for the purpose of overwriting a previous state from
+the cache."
(when (and target (null snapshots))
(error "`futur--obarray' was not properly initialized: %S" target))
(pcase-let ((`(,_ ,old-target ,snapshot) (assq name snapshots)))
@@ -160,9 +170,9 @@ Does not pay attention to buffer-local values of variables."
(setf (alist-get name snapshots)
(list target (futur--obarray-snapshot))))))))))))
-(defun futur-server-call-in-context (ctxname ctx func &rest args)
- (futur--obarray ctxname ctx)
- (apply func args))
+;; (defun futur-server-call-in-context (ctxname ctx func &rest args)
+;; (futur--obarray ctxname ctx)
+;; (apply func args))
(defun futur-server ()
;; We don't need a cryptographically secure ID, but just something that's
@@ -175,7 +185,7 @@ Does not pay attention to buffer-local values of variables."
(emacs-pid)))))
(sid-sym (intern (string-trim sid))))
;; Initialize the cache of obarray snapshots.
- (futur--obarray 'futur--server-internal nil)
+ (futur-reset-context 'futur--server-internal nil)
(futur--print-stdout :ready sid)
(while t
(let ((input (condition-case err (cons :read-success (futur--read-stdin))
diff --git a/futur-tests.el b/futur-tests.el
index f99fa96ad0..392c1a153f 100644
--- a/futur-tests.el
+++ b/futur-tests.el
@@ -180,7 +180,7 @@
(should (<= 0.3 (- (float-time) start) 0.5))))
(ert-deftest futur-server ()
- (let* ((futur (futur--elisp-get-process))
+ (let* ((futur (futur--elisp-get-process 'futur-server #'futur--elisp-launch))
(proc (futur-blocking-wait-to-get-result futur)))
(should (process-get proc 'futur--ready))
(should (null (process-get proc 'futur--destination)))))
@@ -201,17 +201,63 @@
(should (equal (futur-blocking-wait-to-get-result fut)
(documentation 'car))))
- (let* ((fut
+ (let* ((str (let ((chars ()))
+ (dotimes (i 1024)
+ (push i chars))
+ (apply #'string (nreverse chars))))
+ (fut (futur--elisp-funcall #'identity str)))
+ (should (equal (futur-blocking-wait-to-get-result fut)
+ str)))
+
+ (let* ((f (lambda (context)
+ (futur-reset-context
+ 'futur-test-mini context)
+ (symbol-function 'diff-mode)))
+ (fut
+ (futur-let*
+ ((da1 <- (futur--elisp-funcall f ()))
+ (da2 <- (futur--elisp-funcall f '(diff-mode)))
+ (da3 <- (futur--elisp-funcall f ())))
+ (list da1 da2 da3)))
+ (vals (futur-blocking-wait-to-get-result fut)))
+ (should (autoloadp (nth 0 vals)))
+ (should (functionp (nth 1 vals)))
+ (should-not (equal (nth 0 vals) (nth 1 vals)))
+ (should (equal (nth 0 vals) (nth 2 vals)))))
+
+(ert-deftest futur-sandbox-funcall ()
+ (let ((fut (futur--sandbox-funcall #'+ 5 7)))
+ (should (equal 12 (futur-blocking-wait-to-get-result fut))))
+
+ (let ((fut (futur--sandbox-funcall #'car 7)))
+ (should (equal (condition-case err1
+ (futur-blocking-wait-to-get-result fut)
+ (error err1))
+ (condition-case err2
+ (car 7)
+ (error err2)))))
+
+ (let ((fut (futur--sandbox-funcall #'documentation 'car)))
+ (should (equal (futur-blocking-wait-to-get-result fut)
+ (documentation 'car))))
+
+ (let* ((str (let ((chars ()))
+ (dotimes (i 1024)
+ (push i chars))
+ (apply #'string (nreverse chars))))
+ (fut (futur--sandbox-funcall #'identity str)))
+ (should (equal (futur-blocking-wait-to-get-result fut)
+ str)))
+
+ (let* ((f (lambda (context)
+ (futur-reset-context
+ 'futur-test-mini context)
+ (symbol-function 'diff-mode)))
+ (fut
(futur-let*
- ((da1 <- (futur--elisp-funcall #'futur-server-call-in-context
- 'futur-test-mini ()
- #'symbol-function 'diff-mode))
- (da2 <- (futur--elisp-funcall #'futur-server-call-in-context
- 'futur-test-mini '(diff-mode)
- #'symbol-function 'diff-mode))
- (da3 <- (futur--elisp-funcall #'futur-server-call-in-context
- 'futur-test-mini ()
- #'symbol-function 'diff-mode)))
+ ((da1 <- (futur--sandbox-funcall f ()))
+ (da2 <- (futur--sandbox-funcall f '(diff-mode)))
+ (da3 <- (futur--sandbox-funcall f ())))
(list da1 da2 da3)))
(vals (futur-blocking-wait-to-get-result fut)))
(should (autoloadp (nth 0 vals)))
diff --git a/futur.el b/futur.el
index 7d770c50a6..91c1bd779f 100644
--- a/futur.el
+++ b/futur.el
@@ -125,6 +125,10 @@
;;; News:
+;; Since version 1.1:
+
+;; - Preliminary support to run ELisp code in subproceses.
+
;; Version 1.1:
;; - New functions: `futur-race', `futur-sit-for', `futur-url-retrieve'.
