Add (guix least-authority).

* guix/least-authority.scm: New file.
* Makefile.am (MODULES): Add it.
* gnu/build/shepherd.scm (default-mounts): Make public.

3 files changed, 138 insertions, 1 deletions

diff --git a/Makefile.am b/Makefile.am
index 8b92a4a9bb..2c07fe724b 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -130,6 +130,7 @@ MODULES =					\
   guix/cache.scm				\
   guix/cve.scm					\
   guix/workers.scm				\
+  guix/least-authority.scm			\
   guix/ipfs.scm					\
   guix/build-system.scm				\
   guix/build-system/android-ndk.scm		\
diff --git a/gnu/build/shepherd.scm b/gnu/build/shepherd.scm
index d52e53eb78..f4caefce3c 100644
--- a/gnu/build/shepherd.scm
+++ b/gnu/build/shepherd.scm
@@ -31,7 +31,8 @@
                                  exec-command
                                  %precious-signals)
   #:autoload (shepherd system) (unblock-signals)
-  #:export (make-forkexec-constructor/container
+  #:export (default-mounts
+            make-forkexec-constructor/container
             fork+exec-command/container))
 
 ;;; Commentary:
diff --git a/guix/least-authority.scm b/guix/least-authority.scm
new file mode 100644
index 0000000000..d871816fca
--- /dev/null
+++ b/guix/least-authority.scm
@@ -0,0 +1,135 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2022 Ludovic Courtès <ludo@gnu.org>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix 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 Guix 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 Guix.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (guix least-authority)
+  #:use-module (guix gexp)
+  #:use-module (guix modules)
+  #:use-module ((guix store) #:select (%store-prefix))
+  #:autoload   (gnu build linux-container) (%namespaces)
+  #:autoload   (gnu system file-systems) (file-system-mapping
+                                          file-system-mapping-source
+                                          spec->file-system
+                                          file-system->spec
+                                          file-system-mapping->bind-mount)
+  #:export (least-authority-wrapper))
+
+;;; Commentary:
+;;;
+;;; This module provides tools to execute programs with the least authority
+;;; necessary, using Linux namespaces.
+;;;
+;;; Code:
+
+(define %precious-variables
+  ;; Environment variables preserved by the wrapper by default.
+  '("HOME" "USER" "LOGNAME" "DISPLAY" "XAUTHORITY" "TERM" "TZ" "PAGER"))
+
+(define* (least-authority-wrapper program
+                                  #:key (name "pola-wrapper")
+                                  (guest-uid 1000)
+                                  (guest-gid 1000)
+                                  (mappings '())
+                                  (namespaces %namespaces)
+                                  (directory "/")
+                                  (preserved-environment-variables
+                                   %precious-variables))
+  "Return a wrapper of PROGRAM that executes it with the least authority.
+
+PROGRAM is executed in separate namespaces according to NAMESPACES, a list of
+symbols; it turns with GUEST-UID and GUEST-GID.  MAPPINGS is a list of
+<file-system-mapping> records indicating directories mirrored inside the
+execution environment of PROGRAM.  DIRECTORY is the working directory of the
+wrapped process.  Each environment listed in PRESERVED-ENVIRONMENT-VARIABLES
+is preserved; other environment variables are erased."
+  (define code
+    (with-imported-modules (source-module-closure
+                            '((gnu system file-systems)
+                              (gnu build shepherd)
+                              (gnu build linux-container)))
+      #~(begin
+          (use-modules (gnu system file-systems)
+                       (gnu build linux-container)
+                       ((gnu build shepherd) #:select (default-mounts))
+                       (srfi srfi-1))
+
+          (define variables
+            (filter-map (lambda (variable)
+                          (let ((value (getenv variable)))
+                            (and value
+                                 (string-append variable "=" value))))
+                        '#$preserved-environment-variables))
+
+          (define (read-file file)
+            (call-with-input-file file read))
+
+          (define references
+            (delete-duplicates
+             (append-map read-file
+                         '#$(map references-file
+                                 (cons program
+                                       (map file-system-mapping-source
+                                            mappings))))))
+
+          (define (store? file-system)
+            (string=? (file-system-mount-point file-system)
+                      #$(%store-prefix)))
+
+          (define mounts
+            (append (map (lambda (item)
+                           (file-system-mapping->bind-mount
+                            (file-system-mapping (source item)
+                                                 (target item))))
+                         references)
+                    (remove store?
+                            (default-mounts
+                              #:namespaces '#$namespaces))
+                    (map spec->file-system
+                         '#$(map (compose file-system->spec
+                                          file-system-mapping->bind-mount)
+                                 mappings))))
+
+          (define (reify-exit-status status)
+            (cond ((status:exit-val status) => exit)
+                  ((or (status:term-sig status)
+                       (status:stop-sig status))
+                   => (lambda (signal)
+                        (format (current-error-port)
+                                "~a terminated with signal ~a~%"
+                                #$program signal)
+                        (exit (+ 128 signal))))))
+
+          ;; Note: 'call-with-container' creates a sub-process that this one
+          ;; waits for.  This might seem suboptimal but unshare(2) isn't
+          ;; really applicable: the process would still run in the same PID
+          ;; namespace.
+
+          (reify-exit-status
+           (call-with-container mounts
+             (lambda ()
+               (chdir #$directory)
+               (environ variables)
+               (apply execl #$program #$program (cdr (command-line))))
+
+             ;; Don't assume PROGRAM can behave as an init process.
+             #:child-is-pid1? #f
+
+             #:guest-uid #$guest-uid
+             #:guest-gid #$guest-gid
+             #:namespaces '#$namespaces)))))
+
+  (program-file name code))