projects/guix·blob java-team · refs

698 lines · 24.2 KiB

1;;; GNU Guix --- Functional package management for GNU
2;;; Copyright © 2013-2022, 2025 Ludovic Courtès <[email protected]>
3;;; Copyright © 2020 Google LLC
4;;; Copyright © 2020 Jakub Kądziołka <[email protected]>
5;;; Copyright © 2020, 2021 Maxim Cournoyer <[email protected]>
6;;; Copyright © 2021 Tobias Geerinckx-Rice <[email protected]>
7;;; Copyright © 2022 Oleg Pykhalov <[email protected]>
8;;;
9;;; This file is part of GNU Guix.
10;;;
11;;; GNU Guix is free software; you can redistribute it and/or modify it
12;;; under the terms of the GNU General Public License as published by
13;;; the Free Software Foundation; either version 3 of the License, or (at
14;;; your option) any later version.
15;;;
16;;; GNU Guix is distributed in the hope that it will be useful, but
17;;; WITHOUT ANY WARRANTY; without even the implied warranty of
18;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
19;;; GNU General Public License for more details.
20;;;
21;;; You should have received a copy of the GNU General Public License
22;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
23
24(define-module (gnu system file-systems)
25 #:use-module (ice-9 match)
26 #:use-module (rnrs bytevectors)
27 #:use-module (srfi srfi-1)
28 #:use-module (srfi srfi-2)
29 #:use-module (srfi srfi-9)
30 #:use-module (srfi srfi-26)
31 #:use-module (srfi srfi-35)
32 #:use-module (srfi srfi-9 gnu)
33 #:use-module (guix records)
34 #:use-module ((guix diagnostics)
35 #:select (source-properties->location leave &fix-hint))
36 #:use-module (guix i18n)
37 #:use-module (gnu system uuid)
38 #:re-export (uuid ;backward compatibility
39 string->uuid
40 uuid->string)
41 #:export (file-system
42 file-system?
43 file-system-device
44 file-system-device->string
45 file-system-mount-point
46 file-system-type
47 file-system-needed-for-boot?
48 file-system-flags
49 file-system-options
50 file-system-options->alist
51 alist->file-system-options
52
53 file-system-mount?
54 file-system-mount-may-fail?
55 file-system-check?
56 file-system-skip-check-if-clean?
57 file-system-repair
58 file-system-create-mount-point?
59 file-system-dependencies
60 file-system-shepherd-requirements
61 file-system-location
62
63 file-system-type-predicate
64 file-system-mount-point-predicate
65 btrfs-subvolume?
66 btrfs-store-subvolume-file-name
67
68 file-system-label
69 file-system-label?
70 file-system-label->string
71
72 file-system->spec
73 spec->file-system
74 specification->file-system-mapping
75
76 %pseudo-file-system-types
77 %fuse-control-file-system
78 %binary-format-file-system
79 %debug-file-system
80 %efivars-file-system
81 %shared-memory-file-system
82 %pseudo-terminal-file-system
83 %tty-gid
84 %immutable-store
85 %control-groups
86 %elogind-file-systems
87
88 %base-file-systems
89 %base-live-file-systems
90 %container-file-systems
91
92 <file-system-mapping>
93 file-system-mapping
94 file-system-mapping?
95 file-system-mapping-source
96 file-system-mapping-target
97 file-system-mapping-writable?
98
99 file-system-mapping->bind-mount
100
101 %store-mapping
102 %network-configuration-files
103 %network-file-mappings
104
105 swap-space
106 swap-space?
107 swap-space-target
108 swap-space-dependencies
109 swap-space-priority
110 swap-space-discard?))
111
112;;; Commentary:
113;;;
114;;; Declaring file systems to be mounted.
115;;;
116;;; Note: this file system is used both in the Shepherd and on the "host
117;;; side", so it must not include (gnu packages …) modules.
118;;;
119;;; Code:
120
121(eval-when (expand load eval)
122 (define invalid-file-system-flags
123 ;; Note: Keep in sync with 'mount-flags->bit-mask'.
124 (let ((known-flags '(read-only
125 bind-mount no-suid no-dev no-exec
126 no-atime no-diratime strict-atime lazy-time remount
127 shared)))
128 (lambda (flags)
129 "Return the subset of FLAGS that is invalid."
130 (remove (cut memq <> known-flags) flags))))
131
132 (define (%validate-file-system-flags flags location)
133 "Raise an error if FLAGS contains invalid mount flags; otherwise return
134FLAGS."
135 (match (invalid-file-system-flags flags)
136 (() flags)
137 (invalid
138 (leave (source-properties->location location)
139 (N_ "invalid file system mount flag:~{ ~s~}~%"
140 "invalid file system mount flags:~{ ~s~}~%"
141 (length invalid))
142 invalid)))))
143
144(define-syntax validate-file-system-flags
145 (lambda (s)
146 "Validate the given file system mount flags, raising an error if invalid
147flags are found."
148 (syntax-case s (quote)
149 ((_ (quote (symbols ...))) ;validate at expansion time
150 (begin
151 (%validate-file-system-flags (syntax->datum #'(symbols ...))
152 (syntax-source s))
153 #'(quote (symbols ...))))
154 ((_ flags)
155 #`(%validate-file-system-flags flags
156 '#,(datum->syntax s (syntax-source s))))
157 (id
158 (identifier? #'id)
159 #'%validate-file-system-flags))))
160
161;; File system declaration.
162(define-record-type* <file-system> file-system
163 make-file-system
164 file-system?
165 (device file-system-device) ; string | <uuid> | <file-system-label>
166 (mount-point file-system-mount-point) ; string
167 (type file-system-type) ; string
168 (flags file-system-flags ; list of symbols
169 (default '())
170 (sanitize validate-file-system-flags))
171 (options file-system-options ; string or #f
172 (default #f))
173 (mount? file-system-mount? ; Boolean
174 (default #t))
175 (mount-may-fail? file-system-mount-may-fail? ; Boolean
176 (default #f))
177 (needed-for-boot? %file-system-needed-for-boot? ; Boolean
178 (default #f))
179 (check? file-system-check? ; Boolean
180 (default #t))
181 (skip-check-if-clean? file-system-skip-check-if-clean? ; Boolean
182 (default #t))
183 (repair file-system-repair ; symbol or #f
184 (default 'preen))
185 (create-mount-point? file-system-create-mount-point? ; Boolean
186 (default #f))
187 (dependencies file-system-dependencies ; list of <file-system>
188 (default '())) ; or <mapped-device>
189 (shepherd-requirements file-system-shepherd-requirements ; list of symbols
190 (default '()))
191 (location file-system-location
192 (default (current-source-location))
193 (innate)))
194
195;; A file system label for use in the 'device' field.
196(define-record-type <file-system-label>
197 (file-system-label label)
198 file-system-label?
199 (label file-system-label->string))
200
201(set-record-type-printer! <file-system-label>
202 (lambda (obj port)
203 (format port "#<file-system-label ~s>"
204 (file-system-label->string obj))))
205
206;; Note: This module is used both on the build side and on the host side.
207;; Arrange not to pull (guix store) and (guix config) because the latter
208;; differs from user to user.
209(define (%store-prefix)
210 "Return the store prefix."
211 ;; Note: If we have (guix store database) in the search path and we do *not*
212 ;; have (guix store) proper, 'resolve-module' returns an empty (guix store)
213 ;; with one sub-module.
214 (cond ((and=> (parameterize ((current-warning-port (%make-void-port "w0")))
215 (resolve-module '(guix store) #:ensure #f))
216 (lambda (store)
217 (module-variable store '%store-prefix)))
218 =>
219 (lambda (variable)
220 ((variable-ref variable))))
221 ((getenv "NIX_STORE")
222 => identity)
223 (else
224 "/gnu/store")))
225
226(define %not-slash
227 (char-set-complement (char-set #\/)))
228
229(define (file-prefix? file1 file2)
230 "Return #t if FILE1 denotes the name of a file that is a parent of FILE2.
231FILE1 and FILE2 must both be either absolute or relative file names, else #f
232is returned.
233
234For example:
235
236 (file-prefix? \"/gnu\" \"/gnu/store\")
237 => #t
238
239 (file-prefix? \"/gn\" \"/gnu/store\")
240 => #f
241"
242 (define (absolute? file)
243 (string-prefix? "/" file))
244
245 (if (or (every absolute? (list file1 file2))
246 (every (negate absolute?) (list file1 file2)))
247 (let loop ((file1 (string-tokenize file1 %not-slash))
248 (file2 (string-tokenize file2 %not-slash)))
249 (match file1
250 (()
251 #t)
252 ((head1 tail1 ...)
253 (match file2
254 ((head2 tail2 ...)
255 (and (string=? head1 head2) (loop tail1 tail2)))
256 (()
257 #f)))))
258 ;; FILE1 and FILE2 are a mix of absolute and relative file names.
259 #f))
260
261(define (file-name-depth file-name)
262 (length (string-tokenize file-name %not-slash)))
263
264(define* (file-system-device->string device #:key uuid-type)
265 "Return the string representations of the DEVICE field of a <file-system>
266record. When the device is a UUID, its representation is chosen depending on
267UUID-TYPE, a symbol such as 'dce or 'iso9660."
268 (match device
269 ((? file-system-label?)
270 (file-system-label->string device))
271 ((? uuid?)
272 (if uuid-type
273 (uuid->string (uuid-bytevector device) uuid-type)
274 (uuid->string device)))
275 ((? string?)
276 device)))
277
278(define (file-system-options->alist string)
279 "Translate the option string format of a <file-system> record into an
280association list of options or option/value pairs."
281 (if string
282 (let ((options (string-split string #\,)))
283 (map (lambda (param)
284 (let ((=index (string-index param #\=)))
285 (if =index
286 (cons (string-take param =index)
287 (string-drop param (1+ =index)))
288 param)))
289 options))
290 '()))
291
292(define (alist->file-system-options options)
293 "Return the string representation of OPTIONS, an association list. The
294string obtained can be used as the option field of a <file-system> record."
295 (if (null? options)
296 #f
297 (string-join (map (match-lambda
298 ((key . value)
299 (string-append key "=" value))
300 (key
301 key))
302 options)
303 ",")))
304
305(define (file-system-needed-for-boot? fs)
306 "Return true if FS has the 'needed-for-boot?' flag set, or if it's used in the
307boot process--e.g., if FS is the root file system / holds the store."
308 (or (%file-system-needed-for-boot? fs)
309 (and (any (cut file-prefix? (file-system-mount-point fs) <>)
310 (list (%store-prefix)
311 "/etc"
312 "/var/lib"
313 "/var/log"))
314 (not (memq 'bind-mount (file-system-flags fs))))))
315
316(define (file-system->spec fs)
317 "Return a list corresponding to file-system FS that can be passed to the
318initrd code."
319 (match fs
320 (($ <file-system> device mount-point type flags options mount?
321 mount-may-fail? needed-for-boot?
322 check? skip-check-if-clean? repair)
323 ;; Note: Add new fields towards the end for compatibility.
324 (list (cond ((uuid? device)
325 `(uuid ,(uuid-type device) ,(uuid-bytevector device)))
326 ((file-system-label? device)
327 `(file-system-label ,(file-system-label->string device)))
328 (else device))
329 mount-point type flags options mount-may-fail?
330 check? skip-check-if-clean? repair))))
331
332(define (spec->file-system sexp)
333 "Deserialize SEXP, a list, to the corresponding <file-system> object."
334 (match sexp
335 ((device mount-point type flags options mount-may-fail?
336 check? skip-check-if-clean? repair
337 _ ...) ;placeholder for new fields
338 (file-system
339 (device (match device
340 (('uuid (? symbol? type) (? bytevector? bv))
341 (bytevector->uuid bv type))
342 (('file-system-label (? string? label))
343 (file-system-label label))
344 (_
345 device)))
346 (mount-point mount-point) (type type)
347 (flags flags) (options options)
348 (mount-may-fail? mount-may-fail?)
349 (check? check?)
350 (skip-check-if-clean? skip-check-if-clean?)
351 (repair repair)))))
352
353(define (specification->file-system-mapping spec writable?)
354 "Read the SPEC and return the corresponding <file-system-mapping>. SPEC is
355a string of the form \"SOURCE\" or \"SOURCE=TARGET\". The former specifies
356that SOURCE from the host should be mounted at SOURCE in the other system.
357The latter format specifies that SOURCE from the host should be mounted at
358TARGET in the other system."
359 (let ((index (string-index spec #\=)))
360 (if index
361 (file-system-mapping
362 (source (substring spec 0 index))
363 (target (substring spec (+ 1 index)))
364 (writable? writable?))
365 (file-system-mapping
366 (source spec)
367 (target spec)
368 (writable? writable?)))))
369
370
371;;;
372;;; Common file systems.
373;;;
374
375(define %pseudo-file-system-types
376 ;; List of know pseudo file system types. This is used when validating file
377 ;; system definitions.
378 '("9p" "binfmt_misc" "bpf" "cgroup" "cgroup2" "configfs" "debugfs"
379 "devpts" "devtmpfs" "efivarfs" "fusectl" "hugetlbfs" "overlay"
380 "proc" "securityfs" "sysfs" "tmpfs" "tracefs" "virtiofs" "xenfs"))
381
382(define %fuse-control-file-system
383 ;; Control file system for Linux' file systems in user-space (FUSE).
384 (file-system
385 (device "fusectl")
386 (mount-point "/sys/fs/fuse/connections")
387 (type "fusectl")
388 (check? #f)))
389
390(define %binary-format-file-system
391 ;; Support for arbitrary executable binary format.
392 (file-system
393 (device "binfmt_misc")
394 (mount-point "/proc/sys/fs/binfmt_misc")
395 (type "binfmt_misc")
396 (check? #f)))
397
398(define %debug-file-system
399 (file-system
400 (type "debugfs")
401 (device "none")
402 (mount-point "/sys/kernel/debug")
403 (check? #f)
404 (create-mount-point? #t)))
405
406(define %efivars-file-system
407 ;; Support for EFI variables file system.
408 (file-system
409 (device "efivarfs")
410 (mount-point "/sys/firmware/efi/efivars")
411 (type "efivarfs")
412 (mount-may-fail? #t)
413 (needed-for-boot? #f)
414 (check? #f)))
415
416(define %tty-gid
417 ;; ID of the 'tty' group. Allocate it statically to make it easy to refer
418 ;; to it from here and from the 'tty' group definitions.
419 996)
420
421(define %pseudo-terminal-file-system
422 ;; The pseudo-terminal file system. It needs to be mounted so that
423 ;; statfs(2) returns DEVPTS_SUPER_MAGIC like libc's getpt(3) expects (and
424 ;; thus openpty(3) and its users, such as xterm.)
425 (file-system
426 (device "none")
427 (mount-point "/dev/pts")
428 (type "devpts")
429 (check? #f)
430 (needed-for-boot? #f)
431 (create-mount-point? #t)
432 (options (string-append "gid=" (number->string %tty-gid) ",mode=620"))))
433
434(define %shared-memory-file-system
435 ;; Shared memory.
436 (file-system
437 (device "tmpfs")
438 (mount-point "/dev/shm")
439 (type "tmpfs")
440 (check? #f)
441 (flags '(no-suid no-dev))
442 (options "size=50%") ;TODO: make size configurable
443 (create-mount-point? #t)))
444
445(define %immutable-store
446 ;; Read-only store to avoid users or daemons accidentally modifying it.
447 ;; 'guix-daemon' has provisions to remount it read-write in its own name
448 ;; space.
449 (file-system
450 (device (%store-prefix))
451 (mount-point (%store-prefix))
452 (type "none")
453 (check? #f)
454 (flags '(read-only bind-mount no-atime))))
455
456(define %control-groups
457 ;; The cgroup2 file system.
458 (list (file-system
459 (device "none")
460 (mount-point "/sys/fs/cgroup")
461 (type "cgroup2")
462 (check? #f)
463 (create-mount-point? #f))))
464
465(define %elogind-file-systems
466 ;; We don't use systemd, but these file systems are needed for elogind,
467 ;; which was extracted from systemd.
468 (append
469 (list (file-system
470 (device "none")
471 (mount-point "/run/systemd")
472 (type "tmpfs")
473 (check? #f)
474 (flags '(no-suid no-dev no-exec))
475 (options "mode=0755")
476 (create-mount-point? #t))
477 (file-system
478 (device "none")
479 (mount-point "/run/user")
480 (type "tmpfs")
481 (check? #f)
482 (flags '(no-suid no-dev no-exec))
483 (options "mode=0755")
484 (create-mount-point? #t))
485 ;; Elogind uses cgroups to organize processes, allowing it to map PIDs
486 ;; to sessions. Elogind's cgroup hierarchy isn't associated with any
487 ;; resource controller ("subsystem").
488 (file-system
489 (device "cgroup")
490 (mount-point "/sys/fs/cgroup/elogind")
491 (type "cgroup")
492 (check? #f)
493 (options "none,name=elogind")
494 (create-mount-point? #t)
495 (dependencies (list (car %control-groups)))))
496 %control-groups))
497
498(define %base-file-systems
499 ;; List of basic file systems to be mounted. Note that /proc and /sys are
500 ;; currently mounted by the initrd.
501 (list %pseudo-terminal-file-system
502 %debug-file-system
503 %shared-memory-file-system
504 %efivars-file-system
505 %immutable-store))
506
507(define %base-live-file-systems
508 ;; This is the bare minimum to use live file-systems.
509 ;; Used in installation-os.
510 (list (file-system
511 (mount-point "/")
512 (device (file-system-label "Guix_image"))
513 (type "ext4"))
514
515 ;; Make /tmp a tmpfs instead of keeping the overlayfs. This
516 ;; originally was used for unionfs because FUSE creates
517 ;; '.fuse_hiddenXYZ' files for each open file, and this confuses
518 ;; Guix's test suite, for instance (see
519 ;; <http://bugs.gnu.org/23056>). We keep this for overlayfs to be
520 ;; on the safe side.
521 (file-system
522 (mount-point "/tmp")
523 (device "none")
524 (type "tmpfs")
525 (flags '(no-suid no-dev))
526 (check? #f))))
527
528;; File systems for Linux containers differ from %base-file-systems in that
529;; they impose additional restrictions such as no-exec or need different
530;; options to function properly.
531;;
532;; The file system flags and options conform to the libcontainer
533;; specification:
534;; https://github.com/docker/libcontainer/blob/master/SPEC.md#filesystem
535(define %container-file-systems
536 (list
537 ;; Pseudo-terminal file system.
538 (file-system
539 (device "none")
540 (mount-point "/dev/pts")
541 (type "devpts")
542 (flags '(no-exec no-suid))
543 (needed-for-boot? #t)
544 (create-mount-point? #t)
545 (check? #f)
546 (options "newinstance,ptmxmode=0666,mode=620"))
547 ;; Shared memory file system.
548 (file-system
549 (device "tmpfs")
550 (mount-point "/dev/shm")
551 (type "tmpfs")
552 (flags '(no-exec no-suid no-dev))
553 (options "mode=1777,size=65536k")
554 (needed-for-boot? #t)
555 (create-mount-point? #t)
556 (check? #f))
557 ;; Message queue file system.
558 (file-system
559 (device "mqueue")
560 (mount-point "/dev/mqueue")
561 (type "mqueue")
562 (flags '(no-exec no-suid no-dev))
563 (needed-for-boot? #t)
564 (create-mount-point? #t)
565 (check? #f))))
566
567
568;;;
569;;; Shared file systems, for VMs/containers.
570;;;
571
572;; Mapping of host file system SOURCE to mount point TARGET in the guest.
573(define-record-type* <file-system-mapping> file-system-mapping
574 make-file-system-mapping
575 file-system-mapping?
576 (source file-system-mapping-source) ;string
577 (target file-system-mapping-target) ;string
578 (writable? file-system-mapping-writable? ;Boolean
579 (default #f)))
580
581(define (file-system-mapping->bind-mount mapping)
582 "Return a file system that realizes MAPPING, a <file-system-mapping>, using
583a bind mount."
584 (match mapping
585 (($ <file-system-mapping> source target writable?)
586 (file-system
587 (mount-point target)
588 (device source)
589 (type "none")
590 (flags (if writable?
591 '(bind-mount)
592 '(bind-mount read-only)))
593 (check? #f)
594 (create-mount-point? #t)))))
595
596(define %store-mapping
597 ;; Mapping of the host's store into the guest.
598 (file-system-mapping
599 (source (%store-prefix))
600 (target (%store-prefix))
601 (writable? #f)))
602
603(define %network-configuration-files
604 ;; List of essential network configuration files.
605 '("/etc/resolv.conf"
606 "/etc/nsswitch.conf"
607 "/etc/protocols"
608 "/etc/services"
609 "/etc/hosts"))
610
611(define %network-file-mappings
612 ;; List of file mappings for essential network files.
613 (filter-map (lambda (file)
614 (file-system-mapping
615 (source file)
616 (target file)
617 ;; XXX: On some GNU/Linux systems, /etc/resolv.conf is a
618 ;; symlink to a file in a tmpfs which, for an unknown reason,
619 ;; cannot be bind mounted read-only within the container.
620 (writable? (string=? file "/etc/resolv.conf"))))
621 %network-configuration-files))
622
623(define (file-system-type-predicate type)
624 "Return a predicate that, when passed a file system, returns #t if that file
625system has the given TYPE."
626 (lambda (fs)
627 (string=? (file-system-type fs) type)))
628
629(define (file-system-mount-point-predicate mount-point)
630 "Return a predicate that, when passed a file system, returns #t if that file
631system has the given MOUNT-POINT."
632 (lambda (fs)
633 (string=? (file-system-mount-point fs) mount-point)))
634
635
636;;;
637;;; Btrfs specific helpers.
638;;;
639
640(define (btrfs-subvolume? fs)
641 "Predicate to check if FS, a file-system object, is a Btrfs subvolume."
642 (and-let* ((btrfs-file-system? (string= "btrfs" (file-system-type fs)))
643 (option-keys (map (match-lambda
644 ((key . value) key)
645 (key key))
646 (file-system-options->alist
647 (file-system-options fs)))))
648 (find (cut string-prefix? "subvol" <>) option-keys)))
649
650(define (btrfs-store-subvolume-file-name file-systems)
651 "Return the subvolume file name within the Btrfs top level onto which the
652store is located, else #f."
653
654 (define (prepend-slash/maybe s)
655 (if (string=? "/" (string-take s 1))
656 s
657 (string-append "/" s)))
658
659 (and-let* ((btrfs-subvolume-fs (filter btrfs-subvolume? file-systems))
660 (btrfs-subvolume-fs*
661 (sort btrfs-subvolume-fs
662 (lambda (fs1 fs2)
663 (> (file-name-depth (file-system-mount-point fs1))
664 (file-name-depth (file-system-mount-point fs2))))))
665 (store-subvolume-fs
666 (find (lambda (fs) (file-prefix? (file-system-mount-point fs)
667 (%store-prefix)))
668 btrfs-subvolume-fs*))
669 (options (file-system-options->alist
670 (file-system-options store-subvolume-fs))))
671 ;; XXX: Deriving the subvolume name based from a subvolume ID is not
672 ;; supported, as we'd need to query the actual file system.
673 (or (and=> (assoc-ref options "subvol") prepend-slash/maybe)
674 (raise (condition
675 (&message
676 (message "The store is on a Btrfs subvolume, but the \
677subvolume name is unknown."))
678 (&fix-hint
679 (hint
680 (G_ "Use the @code{subvol} Btrfs file system option."))))))))
681
682
683;;;
684;;; Swap space
685;;;
686
687(define-record-type* <swap-space> swap-space make-swap-space
688 swap-space?
689 this-swap-space
690 (target swap-space-target)
691 (dependencies swap-space-dependencies
692 (default '()))
693 (priority swap-space-priority
694 (default #f))
695 (discard? swap-space-discard?
696 (default #f)))
697
698;;; file-systems.scm ends here