blob: bfd7275e7c1003a8ba40cf2a0c69037bb1930894 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
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 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))
|
