mirror of git://git.savannah.gnu.org/guix.git
136 lines
5.7 KiB
Scheme
136 lines
5.7 KiB
Scheme
;;; 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 runs 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))
|