projects/guix·blob mpd-fix-groups · refs

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