Add (guix least-authority).

* guix/least-authority.scm: New file.
* Makefile.am (MODULES): Add it.
* gnu/build/shepherd.scm (default-mounts): Make public.
This commit is contained in:
Ludovic Courtès 2022-04-16 16:11:23 +02:00
parent 391bd14359
commit 3682bd4003
No known key found for this signature in database
GPG Key ID: 090B11993D9AEBB5
3 changed files with 138 additions and 1 deletions

View File

@ -130,6 +130,7 @@ MODULES = \
guix/cache.scm \ guix/cache.scm \
guix/cve.scm \ guix/cve.scm \
guix/workers.scm \ guix/workers.scm \
guix/least-authority.scm \
guix/ipfs.scm \ guix/ipfs.scm \
guix/build-system.scm \ guix/build-system.scm \
guix/build-system/android-ndk.scm \ guix/build-system/android-ndk.scm \

View File

@ -31,7 +31,8 @@
exec-command exec-command
%precious-signals) %precious-signals)
#:autoload (shepherd system) (unblock-signals) #:autoload (shepherd system) (unblock-signals)
#:export (make-forkexec-constructor/container #:export (default-mounts
make-forkexec-constructor/container
fork+exec-command/container)) fork+exec-command/container))
;;; Commentary: ;;; Commentary:

135
guix/least-authority.scm Normal file
View File

@ -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))