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