From aa7780d2a40cf1da60ae236e9468cea9c36a8350 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 2/2] platform-independent sandbox interface

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

diff --git a/lisp/sandbox.el b/lisp/sandbox.el
new file mode 100644
index 0000000000..589d25615a
--- /dev/null
+++ b/lisp/sandbox.el
@@ -0,0 +1,91 @@
+;;; -*- lexical-binding: t -*-
+
+(require 'cl-lib)
+
+(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."
+  (pcase-exhaustive sandbox-mechanism
+    ('darwin
+     (list prog "--eval"
+           (prin1-to-string `(darwin--sandbox-enter ',sandbox-spec))))
+    ('bwrap
+     ;; FIXME: with seccomp?
+     (let* ((read-dirs (plist-get sandbox-spec :read-dirs))
+            (write-dirs (plist-get sandbox-spec :write-dirs))
+            (exec-dirs (plist-get sandbox-spec :exec-dirs))
+            (ro-dirs (cl-set-difference
+                      (cl-union read-dirs exec-dirs :test #'equal)
+                      write-dirs :test #'equal)))
+       `("bwrap"
+         "--unshare-all"
+         "--dev" "/dev"
+         "--proc" "/proc"
+         "--tmpfs" "/tmp"
+         ,@(mapcan (lambda (dir) (let ((d (expand-file-name dir)))
+                                   (list "--ro-bind" d d)))
+                   ro-dirs)
+         ,@(mapcan (lambda (dir) (let ((d (expand-file-name dir)))
+                                   (list "--bind" d d)))
+                   write-dirs)
+         ,prog)))))
+
+(defun sandbox--emacs-command (sandbox-spec args)
+  "Command and arguments for running Emacs with SANDBOX-SPEC and 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:
+ `:read-dirs'  -- the value is a list of directories that can be read from.
+ `:write-dirs' -- the value is a list of directories that can be written to.
+ `:exec-dirs'  -- the value is a list of directories from which
+                  executables can be run as subprocesses.
+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:
+ `:read-dirs'  -- the value is a list of directories that can be read from.
+ `:write-dirs' -- the value is a list of directories that can be written to.
+ `:exec-dirs'  -- the value is a list of directories from which
+                  executables can be run as subprocesses.
+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)

