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