gnu/system/file-systems.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018 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   (cond ((resolve-module '(guix store) #:ensure #f)
 198          =>
 199          (lambda (store)
 200            ((module-ref store '%store-prefix))))
 201         ((getenv "NIX_STORE")
 202          => identity)
 203         (else
 204          "/gnu/store")))
 205
 206 (define %not-slash
 207   (char-set-complement (char-set #\/)))
 208
 209 (define (file-prefix? file1 file2)
 210   "Return #t if FILE1 denotes the name of a file that is a parent of FILE2,
 211 where both FILE1 and FILE2 are absolute file name.  For example:
 212
 213   (file-prefix? \"/gnu\" \"/gnu/store\")
 214   => #t
 215
 216   (file-prefix? \"/gn\" \"/gnu/store\")
 217   => #f
 218 "
 219   (and (string-prefix? "/" file1)
 220        (string-prefix? "/" file2)
 221        (let loop ((file1 (string-tokenize file1 %not-slash))
 222                   (file2 (string-tokenize file2 %not-slash)))
 223          (match file1
 224            (()
 225             #t)
 226            ((head1 tail1 ...)
 227             (match file2
 228               ((head2 tail2 ...)
 229                (and (string=? head1 head2) (loop tail1 tail2)))
 230               (()
 231                #f)))))))
 232
 233 (define (file-system-needed-for-boot? fs)
 234   "Return true if FS has the 'needed-for-boot?' flag set, or if it holds the
 235 store--e.g., if FS is the root file system."
 236   (or (%file-system-needed-for-boot? fs)
 237       (and (file-prefix? (file-system-mount-point fs) (%store-prefix))
 238            (not (memq 'bind-mount (file-system-flags fs))))))
 239
 240 (define (file-system->spec fs)
 241   "Return a list corresponding to file-system FS that can be passed to the
 242 initrd code."
 243   (match fs
 244     (($ <file-system> device mount-point type flags options _ _ check?)
 245      (list (cond ((uuid? device)
 246                   `(uuid ,(uuid-type device) ,(uuid-bytevector device)))
 247                  ((file-system-label? device)
 248                   `(file-system-label ,(file-system-label->string device)))
 249                  (else device))
 250            mount-point type flags options check?))))
 251
 252 (define (spec->file-system sexp)
 253   "Deserialize SEXP, a list, to the corresponding <file-system> object."
 254   (match sexp
 255     ((device mount-point type flags options check?)
 256      (file-system
 257        (device (match device
 258                  (('uuid (? symbol? type) (? bytevector? bv))
 259                   (bytevector->uuid bv type))
 260                  (('file-system-label (? string? label))
 261                   (file-system-label label))
 262                  (_
 263                   device)))
 264        (mount-point mount-point) (type type)
 265        (flags flags) (options options)
 266        (check? check?)))))
 267
 268 (define (specification->file-system-mapping spec writable?)
 269   "Read the SPEC and return the corresponding <file-system-mapping>.  SPEC is
 270 a string of the form \"SOURCE\" or \"SOURCE=TARGET\".  The former specifies
 271 that SOURCE from the host should be mounted at SOURCE in the other system.
 272 The latter format specifies that SOURCE from the host should be mounted at
 273 TARGET in the other system."
 274   (let ((index (string-index spec #\=)))
 275     (if index
 276         (file-system-mapping
 277          (source (substring spec 0 index))
 278          (target (substring spec (+ 1 index)))
 279          (writable? writable?))
 280         (file-system-mapping
 281          (source spec)
 282          (target spec)
 283          (writable? writable?)))))
 284
 285 \f
 286 ;;;
 287 ;;; Common file systems.
 288 ;;;
 289
 290 (define %pseudo-file-system-types
 291   ;; List of know pseudo file system types.  This is used when validating file
 292   ;; system definitions.
 293   '("binfmt_misc" "cgroup" "debugfs" "devpts" "devtmpfs" "efivarfs" "fusectl"
 294     "hugetlbfs" "overlay" "proc" "securityfs" "sysfs" "tmpfs"))
 295
 296 (define %fuse-control-file-system
 297   ;; Control file system for Linux' file systems in user-space (FUSE).
 298   (file-system
 299     (device "fusectl")
 300     (mount-point "/sys/fs/fuse/connections")
 301     (type "fusectl")
 302     (check? #f)))
 303
 304 (define %binary-format-file-system
 305   ;; Support for arbitrary executable binary format.
 306   (file-system
 307     (device "binfmt_misc")
 308     (mount-point "/proc/sys/fs/binfmt_misc")
 309     (type "binfmt_misc")
 310     (check? #f)))
 311
 312 (define %tty-gid
 313   ;; ID of the 'tty' group.  Allocate it statically to make it easy to refer
 314   ;; to it from here and from the 'tty' group definitions.
 315   996)
 316
 317 (define %pseudo-terminal-file-system
 318   ;; The pseudo-terminal file system.  It needs to be mounted so that
 319   ;; statfs(2) returns DEVPTS_SUPER_MAGIC like libc's getpt(3) expects (and
 320   ;; thus openpty(3) and its users, such as xterm.)
 321   (file-system
 322     (device "none")
 323     (mount-point "/dev/pts")
 324     (type "devpts")
 325     (check? #f)
 326     (needed-for-boot? #f)
 327     (create-mount-point? #t)
 328     (options (string-append "gid=" (number->string %tty-gid) ",mode=620"))))
 329
 330 (define %shared-memory-file-system
 331   ;; Shared memory.
 332   (file-system
 333     (device "tmpfs")
 334     (mount-point "/dev/shm")
 335     (type "tmpfs")
 336     (check? #f)
 337     (flags '(no-suid no-dev))
 338     (options "size=50%")                         ;TODO: make size configurable
 339     (create-mount-point? #t)))
 340
 341 (define %immutable-store
 342   ;; Read-only store to avoid users or daemons accidentally modifying it.
 343   ;; 'guix-daemon' has provisions to remount it read-write in its own name
 344   ;; space.
 345   (file-system
 346     (device (%store-prefix))
 347     (mount-point (%store-prefix))
 348     (type "none")
 349     (check? #f)
 350     (flags '(read-only bind-mount))))
 351
 352 (define %control-groups
 353   (let ((parent (file-system
 354                   (device "cgroup")
 355                   (mount-point "/sys/fs/cgroup")
 356                   (type "tmpfs")
 357                   (check? #f))))
 358     (cons parent
 359           (map (lambda (subsystem)
 360                  (file-system
 361                    (device "cgroup")
 362                    (mount-point (string-append "/sys/fs/cgroup/" subsystem))
 363                    (type "cgroup")
 364                    (check? #f)
 365                    (options subsystem)
 366                    (create-mount-point? #t)
 367
 368                    ;; This must be mounted after, and unmounted before the
 369                    ;; parent directory.
 370                    (dependencies (list parent))))
 371                '("cpuset" "cpu" "cpuacct" "memory" "devices" "freezer"
 372                  "blkio" "perf_event")))))
 373
 374 (define %elogind-file-systems
 375   ;; We don't use systemd, but these file systems are needed for elogind,
 376   ;; which was extracted from systemd.
 377   (append
 378    (list (file-system
 379            (device "none")
 380            (mount-point "/run/systemd")
 381            (type "tmpfs")
 382            (check? #f)
 383            (flags '(no-suid no-dev no-exec))
 384            (options "mode=0755")
 385            (create-mount-point? #t))
 386          (file-system
 387            (device "none")
 388            (mount-point "/run/user")
 389            (type "tmpfs")
 390            (check? #f)
 391            (flags '(no-suid no-dev no-exec))
 392            (options "mode=0755")
 393            (create-mount-point? #t))
 394          ;; Elogind uses cgroups to organize processes, allowing it to map PIDs
 395          ;; to sessions.  Elogind's cgroup hierarchy isn't associated with any
 396          ;; resource controller ("subsystem").
 397          (file-system
 398            (device "cgroup")
 399            (mount-point "/sys/fs/cgroup/elogind")
 400            (type "cgroup")
 401            (check? #f)
 402            (options "none,name=elogind")
 403            (create-mount-point? #t)
 404            (dependencies (list (car %control-groups)))))
 405    %control-groups))
 406
 407 (define %base-file-systems
 408   ;; List of basic file systems to be mounted.  Note that /proc and /sys are
 409   ;; currently mounted by the initrd.
 410   (list %pseudo-terminal-file-system
 411         %shared-memory-file-system
 412         %immutable-store))
 413
 414 ;; File systems for Linux containers differ from %base-file-systems in that
 415 ;; they impose additional restrictions such as no-exec or need different
 416 ;; options to function properly.
 417 ;;
 418 ;; The file system flags and options conform to the libcontainer
 419 ;; specification:
 420 ;; https://github.com/docker/libcontainer/blob/master/SPEC.md#filesystem
 421 (define %container-file-systems
 422   (list
 423    ;; Pseudo-terminal file system.
 424    (file-system
 425      (device "none")
 426      (mount-point "/dev/pts")
 427      (type "devpts")
 428      (flags '(no-exec no-suid))
 429      (needed-for-boot? #t)
 430      (create-mount-point? #t)
 431      (check? #f)
 432      (options "newinstance,ptmxmode=0666,mode=620"))
 433    ;; Shared memory file system.
 434    (file-system
 435      (device "tmpfs")
 436      (mount-point "/dev/shm")
 437      (type "tmpfs")
 438      (flags '(no-exec no-suid no-dev))
 439      (options "mode=1777,size=65536k")
 440      (needed-for-boot? #t)
 441      (create-mount-point? #t)
 442      (check? #f))
 443    ;; Message queue file system.
 444    (file-system
 445      (device "mqueue")
 446      (mount-point "/dev/mqueue")
 447      (type "mqueue")
 448      (flags '(no-exec no-suid no-dev))
 449      (needed-for-boot? #t)
 450      (create-mount-point? #t)
 451      (check? #f))))
 452
 453 \f
 454 ;;;
 455 ;;; Shared file systems, for VMs/containers.
 456 ;;;
 457
 458 ;; Mapping of host file system SOURCE to mount point TARGET in the guest.
 459 (define-record-type* <file-system-mapping> file-system-mapping
 460   make-file-system-mapping
 461   file-system-mapping?
 462   (source    file-system-mapping-source)          ;string
 463   (target    file-system-mapping-target)          ;string
 464   (writable? file-system-mapping-writable?        ;Boolean
 465              (default #f)))
 466
 467 (define (file-system-mapping->bind-mount mapping)
 468   "Return a file system that realizes MAPPING, a <file-system-mapping>, using
 469 a bind mount."
 470   (match mapping
 471     (($ <file-system-mapping> source target writable?)
 472      (file-system
 473        (mount-point target)
 474        (device source)
 475        (type "none")
 476        (flags (if writable?
 477                   '(bind-mount)
 478                   '(bind-mount read-only)))
 479        (check? #f)
 480        (create-mount-point? #t)))))
 481
 482 (define %store-mapping
 483   ;; Mapping of the host's store into the guest.
 484   (file-system-mapping
 485    (source (%store-prefix))
 486    (target (%store-prefix))
 487    (writable? #f)))
 488
 489 (define %network-configuration-files
 490   ;; List of essential network configuration files.
 491   '("/etc/resolv.conf"
 492     "/etc/nsswitch.conf"
 493     "/etc/services"
 494     "/etc/hosts"))
 495
 496 (define %network-file-mappings
 497   ;; List of file mappings for essential network files.
 498   (filter-map (lambda (file)
 499                 (file-system-mapping
 500                  (source file)
 501                  (target file)
 502                  ;; XXX: On some GNU/Linux systems, /etc/resolv.conf is a
 503                  ;; symlink to a file in a tmpfs which, for an unknown reason,
 504                  ;; cannot be bind mounted read-only within the container.
 505                  (writable? (string=? file "/etc/resolv.conf"))))
 506               %network-configuration-files))
 507
 508 (define (file-system-type-predicate type)
 509   "Return a predicate that, when passed a file system, returns #t if that file
 510 system has the given TYPE."
 511   (lambda (fs)
 512     (string=? (file-system-type fs) type)))
 513
 514 ;;; file-systems.scm ends here