projects/guix·blob python-team · refs

415 lines · 19.2 KiB

1;;; GNU Guix --- Functional package management for GNU
2;;; Copyright © 2015 David Thompson <[email protected]>
3;;; Copyright © 2016-2017, 2019-2023, 2025 Ludovic Courtès <[email protected]>
4;;; Copyright © 2019 Arun Isaac <[email protected]>
5;;; Copyright © 2020 Efraim Flashner <[email protected]>
6;;; Copyright © 2020 Google LLC
7;;; Copyright © 2022 Ricardo Wurmus <[email protected]>
8;;; Copyright © 2023 Pierre Langlois <[email protected]>
9;;; Copyright © 2024 Leo Nikkilä <[email protected]>
10;;; Copyright © 2024 Andreas Enge <[email protected]>
11;;; Copyright © 2025 Carlo Zancanaro <[email protected]>
12;;;
13;;; This file is part of GNU Guix.
14;;;
15;;; GNU Guix is free software; you can redistribute it and/or modify it
16;;; under the terms of the GNU General Public License as published by
17;;; the Free Software Foundation; either version 3 of the License, or (at
18;;; your option) any later version.
19;;;
20;;; GNU Guix is distributed in the hope that it will be useful, but
21;;; WITHOUT ANY WARRANTY; without even the implied warranty of
22;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
23;;; GNU General Public License for more details.
24;;;
25;;; You should have received a copy of the GNU General Public License
26;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
27
28(define-module (gnu system linux-container)
29 #:use-module (ice-9 match)
30 #:use-module (srfi srfi-1)
31 #:use-module (guix config)
32 #:use-module (guix store)
33 #:use-module (guix gexp)
34 #:use-module (guix derivations)
35 #:use-module (guix monads)
36 #:use-module (guix modules)
37 #:use-module (gnu build linux-container)
38 #:use-module (gnu services)
39 #:use-module (gnu services base)
40 #:use-module (gnu services networking)
41 #:use-module (gnu services shepherd)
42 #:use-module (gnu system)
43 #:use-module (gnu system file-systems)
44 #:use-module (gnu packages linux)
45 #:export (system-container
46 containerized-operating-system
47 container-script
48 eval/container)
49 ;; Re-export some variables from (guix build linux-container), for
50 ;; convenience.
51 #:re-export (%namespaces
52 %writable-/tmp))
53
54(define* (container-essential-services os #:key shared-network?)
55 "Return a list of essential services corresponding to OS, a
56non-containerized OS. This procedure essentially strips essential services
57from OS that are needed on the bare metal and not in a container."
58 (define base
59 (remove (lambda (service)
60 (memq (service-kind service)
61 (cons* (service-kind %linux-bare-metal-service)
62 firmware-service-type
63 system-service-type
64 (if shared-network?
65 (list hosts-service-type)
66 '()))))
67 (operating-system-essential-services os)))
68
69 (cons (service system-service-type
70 `(("locale" ,(operating-system-locale-directory os))))
71 ;; If network is to be shared with the host, remove network
72 ;; configuration files from etc-service.
73 (if shared-network?
74 (modify-services base
75 (etc-service-type
76 files => (remove
77 (match-lambda
78 ((filename _)
79 (member filename
80 (map basename %network-configuration-files))))
81 files)))
82 base)))
83
84(define dummy-networking-service-type
85 (shepherd-service-type
86 'dummy-networking
87 (lambda (provision)
88 (shepherd-service
89 (documentation "Provide loopback and networking without actually
90doing anything.")
91 (provision provision)
92 (start #~(const #t))))
93 '(loopback networking)
94 (description "Provide loopback and networking without actually doing
95anything. This service is used by guest systems running in containers, where
96networking support is provided by the host.")))
97
98(define %nscd-container-caches
99 ;; Similar to %nscd-default-caches but with smaller cache sizes. This allows
100 ;; many containers to coexist on the same machine without exhausting RAM.
101 (map (lambda (cache)
102 (nscd-cache
103 (inherit cache)
104 (max-database-size (expt 2 18)))) ;256KiB
105 %nscd-default-caches))
106
107(define* (containerized-operating-system os mappings
108 #:key
109 shared-network?
110 (extra-file-systems '()))
111 "Return an operating system based on OS for use in a Linux container
112environment. MAPPINGS is a list of <file-system-mapping> to realize in the
113containerized OS. EXTRA-FILE-SYSTEMS is a list of file systems to add to OS."
114 (define user-file-systems
115 (remove (lambda (fs)
116 (let ((target (file-system-mount-point fs))
117 (source (file-system-device fs)))
118 (or (string=? target (%store-prefix))
119 (string=? target "/")
120 (and (string? source)
121 (string-prefix? "/dev/" source))
122 (string-prefix? "/dev/" target)
123 (string-prefix? "/sys/" target))))
124 (operating-system-file-systems os)))
125
126 (define (mapping->fs fs)
127 (file-system (inherit (file-system-mapping->bind-mount fs))
128 (needed-for-boot? #t)))
129
130 (define services-to-drop
131 ;; Service types to filter from the original operating-system. Some of
132 ;; these make no sense in a container (e.g., those that access
133 ;; /dev/tty[0-9]), while others just need to be reinstantiated with
134 ;; different configs that are better suited to containers.
135 (append (list console-font-service-type
136 mingetty-service-type
137 agetty-service-type)
138 (if shared-network?
139 ;; Replace these with dummy-networking-service-type below.
140 (list
141 static-networking-service-type
142 dhcpcd-service-type
143 network-manager-service-type
144 connman-service-type)
145 (list static-networking-service-type)))) ;loopback
146
147 (define services-to-add
148 ;; Many Guix services depend on a 'networking' shepherd
149 ;; service, so make sure to provide a dummy 'networking'
150 ;; service when we are sure that networking is already set up
151 ;; in the host and can be used. That prevents double setup.
152 (if shared-network?
153 (list (service dummy-networking-service-type
154 '(loopback networking)))
155 (list (service dummy-networking-service-type
156 '(loopback)))))
157
158 (define os-with-base-essential-services
159 (operating-system
160 (inherit os)
161 (kernel %dummy-linux-kernel-for-container)
162 (swap-devices '()) ; disable swap
163 (services
164 (append services-to-add
165 (filter-map
166 (lambda (s)
167 (let ((kind (service-kind s))
168 (value (service-value s)))
169 (cond ((memq kind services-to-drop)
170 #f)
171 ((eq? nscd-service-type kind)
172 (service nscd-service-type
173 (nscd-configuration
174 (inherit value)
175 (caches %nscd-container-caches))))
176 ((and (eq? guix-service-type kind)
177 (eq? (guix-configuration-chroot? value)
178 'default))
179 ;; If chroot? is 'default, it should become #f
180 ;; so that guix-daemon can build things even in
181 ;; Docker without '--privileged'.
182 (service guix-service-type
183 (guix-configuration
184 (inherit value)
185 (chroot? #f))))
186 (else s))))
187 (operating-system-user-services os))))
188 (file-systems (append (map mapping->fs
189 (if shared-network?
190 (append %network-file-mappings mappings)
191 mappings))
192 extra-file-systems
193 user-file-systems
194
195 ;; Provide a dummy root file system so we can create
196 ;; a 'boot-parameters' file.
197 (list (file-system
198 (mount-point "/")
199 (device "nothing")
200 (type "dummy")))))))
201
202 ;; `essential-services' is thunked, we need to evaluate it separately.
203 (operating-system
204 (inherit os-with-base-essential-services)
205 (essential-services (container-essential-services
206 os-with-base-essential-services
207 #:shared-network? shared-network?))))
208
209(define* (container-script os #:key (mappings '()) shared-network?)
210 "Return a derivation of a script that runs OS as a Linux container.
211MAPPINGS is a list of <file-system> objects that specify the files/directories
212that will be shared with the host system."
213 (define (mountable-file-system? file-system)
214 ;; Return #t if FILE-SYSTEM should be mounted in the container.
215 (and (not (string=? "/" (file-system-mount-point file-system)))
216 (file-system-needed-for-boot? file-system)))
217
218 (define (os-file-system-specs os)
219 (map file-system->spec
220 (filter mountable-file-system?
221 (operating-system-file-systems os))))
222
223 (let* ((os (containerized-operating-system
224 os (cons %store-mapping mappings)
225 #:shared-network? shared-network?
226 #:extra-file-systems %container-file-systems))
227 (specs (os-file-system-specs os)))
228
229 (define script
230 (with-imported-modules (source-module-closure
231 '((guix build utils)
232 (gnu build linux-container)
233 (guix i18n)
234 (guix diagnostics)))
235 #~(begin
236 (use-modules (gnu build linux-container)
237 (gnu system file-systems) ;spec->file-system
238 (guix build utils)
239 (guix i18n)
240 (guix diagnostics)
241 (srfi srfi-1)
242 (srfi srfi-37)
243 (ice-9 match))
244
245 (define (show-help)
246 (display (G_ "Usage: run-container [OPTION ...]
247Run the container with the given options."))
248 (newline)
249 (display (G_ "
250 --share=SPEC share host file system with read/write access
251 according to SPEC"))
252 (display (G_ "
253 --expose=SPEC expose host file system directory as read-only
254 according to SPEC"))
255 (display (G_ "
256 --pid-file=FILE write the process ID of the container's PID 1
257 process to FILE"))
258 (newline)
259 (display (G_ "
260 -h, --help display this help and exit"))
261 (newline))
262
263 (define %options
264 ;; Specifications of the command-line options.
265 (list (option '(#\h "help") #f #f
266 (lambda args
267 (show-help)
268 (exit 0)))
269 (option '("share") #t #f
270 (lambda (opt name arg result)
271 (alist-cons 'file-system-mapping
272 (specification->file-system-mapping arg #t)
273 result)))
274 (option '("expose") #t #f
275 (lambda (opt name arg result)
276 (alist-cons 'file-system-mapping
277 (specification->file-system-mapping arg #f)
278 result)))
279 (option '("pid-file") #t #f
280 (lambda (opt name arg result)
281 (alist-cons 'pid-file
282 arg
283 result)))))
284
285 (define (parse-options args options)
286 (args-fold args options
287 (lambda (opt name arg . rest)
288 (report-error (G_ "~A: unrecognized option~%") name)
289 (exit 1))
290 (lambda (op res) (cons op res))
291 '()))
292
293 (define (explain pid)
294 ;; XXX: We can't quite call 'bindtextdomain' so there's actually
295 ;; no i18n.
296 ;; XXX: Should we really give both options? 'guix container exec'
297 ;; is a more verbose command. Hard to fail to enter the container
298 ;; when we list two options.
299 (info (G_ "system container is running as PID ~a~%") pid)
300 (info (G_ "Run 'sudo guix container exec ~a /run/current-system/profile/bin/bash --login'\n")
301 pid)
302 (info (G_ "or run 'sudo nsenter -a -t ~a' to get a shell into it.~%") pid)
303 (newline (guix-warning-port)))
304
305 (let* ((opts (parse-options (cdr (command-line)) %options))
306 (pid-files (filter-map (match-lambda
307 (('pid-file . filename) filename)
308 (_ #f))
309 opts))
310 (mappings (filter-map (match-lambda
311 (('file-system-mapping . mapping) mapping)
312 (_ #f))
313 opts))
314 (file-systems
315 (filter-map (lambda (fs)
316 (let ((flags (file-system-flags fs)))
317 (and (or (not (memq 'bind-mount flags))
318 (file-exists? (file-system-device fs)))
319 fs)))
320 (append (map file-system-mapping->bind-mount mappings)
321 (map spec->file-system '#$specs)))))
322 (call-with-container file-systems
323 (lambda ()
324 (setenv "HOME" "/root")
325 (setenv "TMPDIR" "/tmp")
326 (setenv "GUIX_NEW_SYSTEM" #$os)
327 (for-each mkdir-p '("/run" "/bin" "/etc" "/home" "/var"))
328 (primitive-load (string-append #$os "/boot")))
329 ;; A range of 65536 uid/gids is used to cover 16 bits worth of
330 ;; users and groups, which is sufficient for most cases.
331 ;;
332 ;; See: http://www.freedesktop.org/software/systemd/man/systemd-nspawn.html#--private-users=
333 #:host-uids 65536
334 #:namespaces (if #$shared-network?
335 (delq 'net %namespaces)
336 %namespaces)
337
338 ;; XXX: Work around <https://codeberg.org/guix/guix/issues/4788>.
339 #:lock-mounts? #f
340
341 #:writable-root? #t
342 #:process-spawned-hook (lambda (pid)
343 ;; Write out the PID to the requested files
344 (for-each (lambda (filename)
345 (call-with-output-file filename
346 (lambda (port) (write pid port))))
347 pid-files)
348 (explain pid)))))))
349
350 (gexp->script "run-container" script)))
351
352(define* (eval/container exp
353 #:key
354 (populate-file-system (const #t))
355 writable-root?
356 (mappings '())
357 (mounts '())
358 (namespaces %namespaces)
359 (guest-uid 0) (guest-gid 0)
360 (child-is-pid1? #t))
361 "Evaluate EXP, a gexp, in a new process executing in separate namespaces as
362listed in NAMESPACES. Add MOUNTS, a list of <file-system>, and MAPPINGS, a
363list of <file-system-mapping>, to the set of directories visible in the
364process's mount namespace. Inside the namespaces, run code as GUEST-UID and
365GUEST-GID. Return the process' exit status as a monadic value.
366
367When CHILD-IS-PID1? is true, and if NAMESPACES contains 'pid', then the child
368process runs directly as PID 1. See the documentation for
369`(@@ (gnu build linux-container) call-with-container)` for further details.
370
371This is useful to implement processes that, unlike derivations, are not
372entirely pure and need to access the outside world or to perform side
373effects."
374 (mlet %store-monad ((lowered (lower-gexp exp)))
375 (define inputs
376 (cons (lowered-gexp-guile lowered)
377 (lowered-gexp-inputs lowered)))
378
379 (define items
380 (append (append-map derivation-input-output-paths inputs)
381 (lowered-gexp-sources lowered)))
382
383 (mbegin %store-monad
384 (built-derivations inputs)
385 (mlet %store-monad ((closure ((store-lift requisites) items)))
386 (return (call-with-container (append mounts
387 (map file-system-mapping->bind-mount
388 (append (map (lambda (item)
389 (file-system-mapping
390 (source item)
391 (target source)))
392 closure)
393 mappings)))
394 (lambda ()
395 (apply execl
396 (string-append (derivation-input-output-path
397 (lowered-gexp-guile lowered))
398 "/bin/guile")
399 "guile"
400 (append (append-map (lambda (directory)
401 `("-L" ,directory))
402 (lowered-gexp-load-path lowered))
403 (append-map (lambda (directory)
404 `("-C" ,directory))
405 (lowered-gexp-load-compiled-path
406 lowered))
407 (list "-c"
408 (object->string
409 (lowered-gexp-sexp lowered))))))
410 #:writable-root? writable-root?
411 #:populate-file-system populate-file-system
412 #:namespaces namespaces
413 #:guest-uid guest-uid
414 #:guest-gid guest-gid
415 #:child-is-pid1? child-is-pid1?))))))