[jackhill/guix/guix.git] / guix / least-authority.scm

;;; 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))
Commit	Line	Data
3682bd40 LC	1	;;; GNU Guix --- Functional package management for GNU
	2	;;; Copyright © 2022 Ludovic Courtès <ludo@gnu.org>
	3	;;;
	4	;;; This file is part of GNU Guix.
	5	;;;
	6	;;; GNU Guix is free software; you can redistribute it and/or modify it
	7	;;; under the terms of the GNU General Public License as published by
	8	;;; the Free Software Foundation; either version 3 of the License, or (at
	9	;;; your option) any later version.
	10	;;;
	11	;;; GNU Guix is distributed in the hope that it will be useful, but
	12	;;; WITHOUT ANY WARRANTY; without even the implied warranty of
	13	;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
	14	;;; GNU General Public License for more details.
	15	;;;
	16	;;; You should have received a copy of the GNU General Public License
	17	;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
	18
	19	(define-module (guix least-authority)
	20	#:use-module (guix gexp)
	21	#:use-module (guix modules)
	22	#:use-module ((guix store) #:select (%store-prefix))
	23	#:autoload (gnu build linux-container) (%namespaces)
	24	#:autoload (gnu system file-systems) (file-system-mapping
	25	file-system-mapping-source
	26	spec->file-system
	27	file-system->spec
	28	file-system-mapping->bind-mount)
	29	#:export (least-authority-wrapper))
	30
	31	;;; Commentary:
	32	;;;
	33	;;; This module provides tools to execute programs with the least authority
	34	;;; necessary, using Linux namespaces.
	35	;;;
	36	;;; Code:
	37
	38	(define %precious-variables
	39	;; Environment variables preserved by the wrapper by default.
	40	'("HOME" "USER" "LOGNAME" "DISPLAY" "XAUTHORITY" "TERM" "TZ" "PAGER"))
	41
	42	(define* (least-authority-wrapper program
	43	#:key (name "pola-wrapper")
	44	(guest-uid 1000)
	45	(guest-gid 1000)
	46	(mappings '())
	47	(namespaces %namespaces)
	48	(directory "/")
	49	(preserved-environment-variables
	50	%precious-variables))
	51	"Return a wrapper of PROGRAM that executes it with the least authority.
	52
	53	PROGRAM is executed in separate namespaces according to NAMESPACES, a list of
8994e13b	54	symbols; it runs with GUEST-UID and GUEST-GID. MAPPINGS is a list of
3682bd40 LC	55	<file-system-mapping> records indicating directories mirrored inside the
	56	execution environment of PROGRAM. DIRECTORY is the working directory of the
	57	wrapped process. Each environment listed in PRESERVED-ENVIRONMENT-VARIABLES
	58	is preserved; other environment variables are erased."
	59	(define code
	60	(with-imported-modules (source-module-closure
	61	'((gnu system file-systems)
	62	(gnu build shepherd)
	63	(gnu build linux-container)))
	64	#~(begin
	65	(use-modules (gnu system file-systems)
	66	(gnu build linux-container)
	67	((gnu build shepherd) #:select (default-mounts))
	68	(srfi srfi-1))
	69
	70	(define variables
	71	(filter-map (lambda (variable)
	72	(let ((value (getenv variable)))
	73	(and value
	74	(string-append variable "=" value))))
	75	'#$preserved-environment-variables))
	76
	77	(define (read-file file)
	78	(call-with-input-file file read))
	79
	80	(define references
	81	(delete-duplicates
	82	(append-map read-file
	83	'#$(map references-file
	84	(cons program
	85	(map file-system-mapping-source
	86	mappings))))))
	87
	88	(define (store? file-system)
	89	(string=? (file-system-mount-point file-system)
	90	#$(%store-prefix)))
	91
	92	(define mounts
	93	(append (map (lambda (item)
	94	(file-system-mapping->bind-mount
	95	(file-system-mapping (source item)
	96	(target item))))
	97	references)
	98	(remove store?
	99	(default-mounts
	100	#:namespaces '#$namespaces))
	101	(map spec->file-system
	102	'#$(map (compose file-system->spec
	103	file-system-mapping->bind-mount)
	104	mappings))))
	105
	106	(define (reify-exit-status status)
	107	(cond ((status:exit-val status) => exit)
	108	((or (status:term-sig status)
	109	(status:stop-sig status))
	110	=> (lambda (signal)
	111	(format (current-error-port)
	112	"~a terminated with signal ~a~%"
	113	#$program signal)
	114	(exit (+ 128 signal))))))
	115
	116	;; Note: 'call-with-container' creates a sub-process that this one
	117	;; waits for. This might seem suboptimal but unshare(2) isn't
	118	;; really applicable: the process would still run in the same PID
119	;; namespace.
120
121	(reify-exit-status
122	(call-with-container mounts
123	(lambda ()
124	(chdir #$directory)
125	(environ variables)
126	(apply execl #$program #$program (cdr (command-line))))
127
128	;; Don't assume PROGRAM can behave as an init process.
129	#:child-is-pid1? #f
130
131	#:guest-uid #$guest-uid
132	#:guest-gid #$guest-gid
133	#:namespaces '#$namespaces)))))
134
135	(program-file name code))