From 1dfea4588286ec4177619bd5d20502803a98c4c0 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Mattias=20Engdeg=C3=A5rd?= <mattiase@acm.org>
Date: Fri, 17 Sep 2021 09:30:53 +0200
Subject: [PATCH] platform-independent sandbox interface

---
 lisp/sandbox.el | 77 +++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 77 insertions(+)
 create mode 100644 lisp/sandbox.el

diff --git a/lisp/sandbox.el b/lisp/sandbox.el
new file mode 100644
index 0000000000..a8069d59c7
--- /dev/null
+++ b/lisp/sandbox.el
@@ -0,0 +1,77 @@
+;;; -*- lexical-binding: t -*-
+
+(defconst sandbox-mechanism
+  ;; FIXME: make it a defcustom? What about other systems?
+  (cond ((eq system-type 'darwin) 'darwin)
+        ((eq system-type 'gnu/linux) 'bwrap)))
+
+(defun sandbox-available-p ()
+  "Non-nil if a sandboxing mechanism is available."
+  ;; FIXME: We should check for availability of bwrap etc.
+  (not (null sandbox-mechanism)))
+
+(defun sandbox--program-args (sandbox-spec prog)
+  "Return (PROGRAM . ARGS) for running PROG according to SANDBOX-SPEC."
+  (let ((allow-read-dirs (plist-get sandbox-spec :allow-read-dirs)))
+    ;; FIXME: Would `:allow-write-dirs' make sense and be useful?
+    (pcase-exhaustive sandbox-mechanism
+      ('darwin
+       (list prog "--eval"
+             (prin1-to-string `(darwin-sandbox-enter ',allow-read-dirs))))
+      ('bwrap
+       ;; FIXME: with seccomp?
+       `("bwrap"
+         "--unshare-all"
+         "--dev" "/dev"
+         "--proc" "/proc"
+         "--tmpfs" "/tmp"
+         ,@(mapcan (lambda (dir) (let ((d (expand-file-name dir)))
+                                   (list "--ro-bind" d d)))
+                   allow-read-dirs)
+         ,prog)))))
+
+(defun sandbox--emacs-command (sandbox-spec args)
+  (let* ((emacs (expand-file-name invocation-name invocation-directory))
+         (program-args (sandbox--program-args sandbox-spec emacs)))
+    `(,@program-args "--batch" ,@args)))
+
+(defun sandbox-run-emacs (sandbox-spec destination args)
+  "Run sandboxed Emacs in batch mode, synchronously.
+SANDBOX-SPEC is a sandbox specification plist.  Currently defined key:
+ `:allow-read-dirs' -- the value is a list of directories that can
+                       be read from (but not written to).
+DESTINATION is as in `call-process'.
+ARGS is a list of command-line arguments passed to the sandboxed Emacs.
+Return value is as in `call-process'.
+
+Depending on the platform, the sandbox restrictions do not necessarily
+take effect until Emacs has been initialised and loaded the site and user
+init files.  If that is not desirable, suppress their use by adding the
+corresponding flags (eg \"-Q\") to ARGS."
+  (let ((command (sandbox--emacs-command sandbox-spec args)))
+    (apply #'call-process (car command) nil destination nil (cdr command))))
+
+(defun sandbox-start-emacs (sandbox-spec params args)
+  "Run sandboxed Emacs in batch mode, asynchronously.
+SANDBOX-SPEC is a sandbox specification plist.  Currently defined key:
+ `:allow-read-dirs' -- the value is a list of directories that can
+                       be read from (but not written to).
+ARGS is a list of command-line arguments passed to the sandboxed Emacs.
+PARAMS is a plist of parameters passed to `make-process'.  Do not
+  supply `:command'; it will be overridden by ARGS.
+Return value is as in `make-process'.
+
+Depending on the platform, the sandbox restrictions do not necessarily
+take effect until Emacs has been initialised and loaded the site and user
+init files.  If that is not desirable, suppress their use by adding the
+corresponding flags (eg \"-Q\") to ARGS."
+  (let* ((command (sandbox--emacs-command sandbox-spec args))
+         (params (copy-sequence params))
+         (params (plist-put params :command command)))
+    (unless (plist-member params :name)
+      (setq params (plist-put params :name "emacs")))
+    (unless (plist-member params :connection-type)
+      (setq params (plist-put params :connection-type 'pipe)))
+    (apply #'make-process params)))
+
+(provide 'sandbox)
-- 
2.21.1 (Apple Git-122.3)

