From c5006dc5260f547ff132fd42c580ea0e0fb227a7 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] 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 list of directories under which files can be
read.  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            | 40 ++++++++++++++++
 lisp/loadup.el                |  2 +
 src/sysdep.c                  | 34 +++++++++++++
 test/lisp/darwin-fns-tests.el | 90 +++++++++++++++++++++++++++++++++++
 4 files changed, 166 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..e45aaa0c4e
--- /dev/null
+++ b/lisp/darwin-fns.el
@@ -0,0 +1,40 @@
+;;; 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 (dirs)
+  "Enter a sandbox only permitting reading files under DIRS.
+DIRS is a list of directory names.  Most other operations such as
+writing files and network access are disallowed.
+Existing open descriptors can still be used freely.
+
+This is not a supported interface and is for internal use only."
+  (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))
+                      dirs ""))))
+
+(provide 'darwin-fns)
+
+;;; darwin-fns.el ends here
diff --git a/lisp/loadup.el b/lisp/loadup.el
index d6cfcd6fc8..a6a7251d4b 100644
--- a/lisp/loadup.el
+++ b/lisp/loadup.el
@@ -324,6 +324,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 d940acc4e0..4ea1f0050a 100644
--- a/src/sysdep.c
+++ b/src/sysdep.c
@@ -4286,8 +4286,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..1e426407a1
--- /dev/null
+++ b/test/lisp/darwin-fns-tests.el
@@ -0,0 +1,90 @@
+;;; 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 '(,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)

