gnu/system/file-systems.scm

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