gnu/system/file-systems.scm

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