1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
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)
|