gnu/system/file-systems.scm

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