bug#45198: 28.0.50; Sandbox mode

["Mattias Engdegård" <mattiase@acm.org>]

[-- Attachment #1: Type: text/plain, Size: 497 bytes --]

17 sep. 2021 kl. 15.20 skrev Stefan Monnier <monnier@iro.umontreal.ca>:

> For `elpa-admin.el` we need a writable directory as well.
> We also need the ability to run sub-processes.  Your `bwrap`
> implementation for GNU/Linux should allow that, AFAICT, but I can't tell
> if `darwin-sandbox-enter` also allows it.

Looks like it can be made to work.

Of course this whole exercise doesn't really touch the questions that really matter, such as whether it is practical for actual use.


[-- Attachment #2: 0001-Add-macOS-sandboxing-bug-45198.patch --]
[-- Type: application/octet-stream, Size: 10223 bytes --]

From 03233ad9abb0c18bdbd00eb2cad42db8a252cafe Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Mattias=20Engdeg=C3=A5rd?= <mattiase@acm.org>
Date: Sat, 17 Apr 2021 20:53:39 +0200
Subject: [PATCH 1/2] Add macOS sandboxing (bug#45198)

This is the corresponding low-level sandboxing facility corresponding
to the recently added Seccomp for Linux.  `darwin-sandbox-init` gives
direct access to the system sandboxing call; `darwin--sandbox-enter`
is a wrapper that takes a plist specifying directories under which
files can be read, written or executed.  These should be considered
internal mechanisms for now.

* lisp/darwin-fns.el: New file.
* lisp/loadup.el: Load it.
* src/sysdep.c (Fdarwin_sandbox_init): New function.
* test/lisp/darwin-fns-tests.el: New file.
---
 lisp/darwin-fns.el            | 56 +++++++++++++++++++++
 lisp/loadup.el                |  2 +
 src/sysdep.c                  | 34 +++++++++++++
 test/lisp/darwin-fns-tests.el | 91 +++++++++++++++++++++++++++++++++++
 4 files changed, 183 insertions(+)
 create mode 100644 lisp/darwin-fns.el
 create mode 100644 test/lisp/darwin-fns-tests.el

diff --git a/lisp/darwin-fns.el b/lisp/darwin-fns.el
new file mode 100644
index 0000000000..feba9739b5
--- /dev/null
+++ b/lisp/darwin-fns.el
@@ -0,0 +1,56 @@
+;;; darwin-fns.el --- Darwin-specific functions  -*- lexical-binding: t -*-
+
+;; Copyright (C) 2021 Free Software Foundation, Inc.
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs 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.
+
+;; GNU Emacs 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 GNU Emacs.  If not, see <https://www.gnu.org/licenses/>.
+
+;;; Code:
+
+(defun darwin--sandbox-enter (spec)
+  "Enter a sandbox only permitting actions described by SPEC.
+SPEC is a plist allowing the keys:
+`:read-dirs'  -- value is a list of directories in which reading is allowed.
+`:write-dirs' -- value is a list of directories in which writing is allowed.
+`:exec-dirs'  -- value is a list of directories from which executables
+                 can be run as subprocesses.
+Most other operations such as network access are disallowed.
+Existing open descriptors can still be used freely.
+
+This is not a supported interface and is for internal use only."
+  (let ((read-dirs (plist-get spec :read-dirs))
+        (write-dirs (plist-get spec :write-dirs))
+        (exec-dirs (plist-get spec :exec-dirs)))
+    (darwin-sandbox-init
+     (concat
+      "(version 1)\n"
+      "(deny default)\n"
+      ;; Emacs seems to need /dev/null; allowing it does no harm.
+      "(allow file-read* (path \"/dev/null\"))\n"
+      (mapconcat (lambda (dir)
+                   (format "(allow file-read* (subpath %S))\n" dir))
+                 read-dirs "")
+      (mapconcat (lambda (dir)
+                   (format "(allow file-write* (subpath %S))\n" dir))
+                 write-dirs "")
+      (mapconcat (lambda (dir)
+                   (format "(allow process-exec (subpath %S))\n" dir))
+                 exec-dirs "")
+      (and exec-dirs
+           "(allow process-fork)\n")))))
+
+(provide 'darwin-fns)
+
+;;; darwin-fns.el ends here
diff --git a/lisp/loadup.el b/lisp/loadup.el
index 158c02ecea..163b639640 100644
--- a/lisp/loadup.el
+++ b/lisp/loadup.el
@@ -325,6 +325,8 @@
       (load "term/pc-win")
       (load "ls-lisp")
       (load "disp-table"))) ; needed to setup ibm-pc char set, see internal.el
+(if (eq system-type 'darwin)
+    (load "darwin-fns"))
 (if (featurep 'ns)
     (progn
       (load "term/common-win")
diff --git a/src/sysdep.c b/src/sysdep.c
index 8eaee22498..79a1fad4da 100644
--- a/src/sysdep.c
+++ b/src/sysdep.c
@@ -4458,8 +4458,42 @@ str_collate (Lisp_Object s1, Lisp_Object s2,
 }
 #endif	/* WINDOWSNT */
 
+#ifdef DARWIN_OS
+
+/* This function prototype is not in the platform header files.
+   See https://reverse.put.as/wp-content/uploads/2011/09/Apple-Sandbox-Guide-v1.0.pdf
+   and https://chromium.googlesource.com/chromium/src/+/master/sandbox/mac/seatbelt_sandbox_design.md */
+int sandbox_init_with_parameters(const char *profile,
+                                 uint64_t flags,
+                                 const char *const parameters[],
+                                 char **errorbuf);
+
+DEFUN ("darwin-sandbox-init", Fdarwin_sandbox_init, Sdarwin_sandbox_init,
+       1, 1, 0,
+       doc: /* Enter a sandbox whose permitted access is curtailed by PROFILE.
+Already open descriptors can be used freely.
+PROFILE is a string in the macOS sandbox profile language,
+a set of rules in a Lisp-like syntax.
+
+This is not a supported interface and is for internal use only. */)
+  (Lisp_Object profile)
+{
+  CHECK_STRING (profile);
+  if (memchr (SSDATA (profile), '\0', SBYTES (profile)))
+    error ("NUL in sandbox profile");
+  char *err = NULL;
+  if (sandbox_init_with_parameters (SSDATA (profile), 0, NULL, &err) != 0)
+    error ("sandbox error: %s", err);
+  return Qnil;
+}
+
+#endif	/* DARWIN_OS */
+
 void
 syms_of_sysdep (void)
 {
   defsubr (&Sget_internal_run_time);
+#ifdef DARWIN_OS
+  defsubr (&Sdarwin_sandbox_init);
+#endif
 }
diff --git a/test/lisp/darwin-fns-tests.el b/test/lisp/darwin-fns-tests.el
new file mode 100644
index 0000000000..fa0d58ac3d
--- /dev/null
+++ b/test/lisp/darwin-fns-tests.el
@@ -0,0 +1,91 @@
+;;; darwin-fns-tests.el --- tests for darwin-fns.el  -*- lexical-binding: t -*-
+
+;; Copyright (C) 2021  Free Software Foundation, Inc.
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs 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.
+
+;; GNU Emacs 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 GNU Emacs.  If not, see <https://www.gnu.org/licenses/>.
+
+(require 'ert)
+
+(defun darwin-fns-tests--run-emacs (expr1 expr2)
+  "Run Emacs in batch mode and evaluate EXPR1 and EXPR2.
+Return (EXIT-STATUS . OUTPUT), where OUTPUT is stderr and stdout."
+  (let ((emacs (expand-file-name invocation-name invocation-directory))
+        (process-environment nil))
+    (with-temp-buffer
+      (let ((res (call-process emacs nil t nil
+                               "--quick" "--batch"
+                               (format "--eval=%S" expr1)
+                               (format "--eval=%S" expr2))))
+        (cons res (buffer-string))))))
+
+(ert-deftest darwin-fns-sandbox ()
+  (skip-unless (eq system-type 'darwin))
+  ;; Test file reading and writing under various sandboxing conditions.
+  (let* ((some-text "abcdef")
+         (new-text "ghijkl")
+         (test-file (file-truename (make-temp-file "test")))
+         (file-dir (file-name-directory test-file)))
+    (unwind-protect
+        (dolist (mode '(read write))
+          (ert-info ((symbol-name mode) :prefix "mode: ")
+            (dolist (sandbox '(allow-all deny-all allow-read))
+              (ert-info ((symbol-name sandbox) :prefix "sandbox: ")
+                ;; Prepare initial file contents.
+                (with-temp-buffer
+                  (insert some-text)
+                  (write-file test-file))
+
+                (let* ((sandbox-form
+                        (pcase-exhaustive sandbox
+                          ('allow-all nil)
+                          ('deny-all '(darwin--sandbox-enter nil))
+                          ('allow-read `(darwin--sandbox-enter
+                                         '(:read-dirs (,file-dir))))))
+                       (action-form
+                        (pcase-exhaustive mode
+                          ('read `(progn (find-file-literally ,test-file)
+                                         (message "OK: %s" (buffer-string))))
+                          ('write `(with-temp-buffer
+                                     (insert ,new-text)
+                                     (write-file ,test-file)))))
+                       (allowed (or (eq sandbox 'allow-all)
+                                    (and (eq sandbox 'allow-read)
+                                         (eq mode 'read))))
+                       (res-out (darwin-fns-tests--run-emacs
+                                 sandbox-form action-form))
+                       (exit-status (car res-out))
+                       (output (cdr res-out))
+                       (file-contents
+                        (with-temp-buffer
+                          (insert-file-contents-literally test-file)
+                          (buffer-string))))
+                  (if allowed
+                      (should (equal exit-status 0))
+                    (should-not (equal exit-status 0)))
+                  (when (eq mode 'read)
+                    (if allowed
+                        (should (equal output (format "OK: %s\n" some-text)))
+                      (should-not (string-search some-text output))))
+                  (should (equal file-contents
+                                 (if (and (eq mode 'write) allowed)
+                                     new-text
+                                   some-text))))))))
+
+      ;; Clean up.
+      (ignore-errors (delete-file test-file)))))
+
+
+(provide 'darwin-fns-tests)
-- 
2.21.1 (Apple Git-122.3)


[-- Attachment #3: 0002-platform-independent-sandbox-interface.patch --]
[-- Type: application/octet-stream, Size: 4934 bytes --]

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)