@@ -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 \
@@ -31,7 +31,8 @@ (define-module (gnu build shepherd)
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:
new file mode 100644
@@ -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))