gnu/system/file-systems.scm

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