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 (guix records)
  24   #:use-module (gnu system uuid)
  25   #:re-export (uuid                               ;backward compatibility
  26                string->uuid
  27                uuid->string)
  28   #:export (<file-system>
  29             file-system
  30             file-system?
  31             file-system-device
  32             file-system-title
  33             file-system-mount-point
  34             file-system-type
  35             file-system-needed-for-boot?
  36             file-system-flags
  37             file-system-options
  38             file-system-mount?
  39             file-system-check?
  40             file-system-create-mount-point?
  41             file-system-dependencies
  42             file-system-location
  43
  44             file-system-type-predicate
  45
  46             file-system->spec
  47             spec->file-system
  48             specification->file-system-mapping
  49
  50             %pseudo-file-system-types
  51             %fuse-control-file-system
  52             %binary-format-file-system
  53             %shared-memory-file-system
  54             %pseudo-terminal-file-system
  55             %tty-gid
  56             %immutable-store
  57             %control-groups
  58             %elogind-file-systems
  59
  60             %base-file-systems
  61             %container-file-systems
  62
  63             <file-system-mapping>
  64             file-system-mapping
  65             file-system-mapping?
  66             file-system-mapping-source
  67             file-system-mapping-target
  68             file-system-mapping-writable?
  69
  70             file-system-mapping->bind-mount
  71
  72             %store-mapping
  73             %network-configuration-files
  74             %network-file-mappings))
  75
  76 ;;; Commentary:
  77 ;;;
  78 ;;; Declaring file systems to be mounted.
  79 ;;;
  80 ;;; Note: this file system is used both in the Shepherd and on the "host
  81 ;;; side", so it must not include (gnu packages …) modules.
  82 ;;;
  83 ;;; Code:
  84
  85 ;; File system declaration.
  86 (define-record-type* <file-system> file-system
  87   make-file-system
  88   file-system?
  89   (device           file-system-device)           ; string
  90   (title            file-system-title             ; 'device | 'label | 'uuid
  91                     (default 'device))
  92   (mount-point      file-system-mount-point)      ; string
  93   (type             file-system-type)             ; string
  94   (flags            file-system-flags             ; list of symbols
  95                     (default '()))
  96   (options          file-system-options           ; string or #f
  97                     (default #f))
  98   (mount?           file-system-mount?            ; Boolean
  99                     (default #t))
 100   (needed-for-boot? %file-system-needed-for-boot? ; Boolean
 101                     (default #f))
 102   (check?           file-system-check?            ; Boolean
 103                     (default #t))
 104   (create-mount-point? file-system-create-mount-point? ; Boolean
 105                        (default #f))
 106   (dependencies     file-system-dependencies      ; list of <file-system>
 107                     (default '()))                ; or <mapped-device>
 108   (location         file-system-location
 109                     (default (current-source-location))
 110                     (innate)))
 111
 112 ;; Note: This module is used both on the build side and on the host side.
 113 ;; Arrange not to pull (guix store) and (guix config) because the latter
 114 ;; differs from user to user.
 115 (define (%store-prefix)
 116   "Return the store prefix."
 117   (cond ((resolve-module '(guix store) #:ensure #f)
 118          =>
 119          (lambda (store)
 120            ((module-ref store '%store-prefix))))
 121         ((getenv "NIX_STORE")
 122          => identity)
 123         (else
 124          "/gnu/store")))
 125
 126 (define %not-slash
 127   (char-set-complement (char-set #\/)))
 128
 129 (define (file-prefix? file1 file2)
 130   "Return #t if FILE1 denotes the name of a file that is a parent of FILE2,
 131 where both FILE1 and FILE2 are absolute file name.  For example:
 132
 133   (file-prefix? \"/gnu\" \"/gnu/store\")
 134   => #t
 135
 136   (file-prefix? \"/gn\" \"/gnu/store\")
 137   => #f
 138 "
 139   (and (string-prefix? "/" file1)
 140        (string-prefix? "/" file2)
 141        (let loop ((file1 (string-tokenize file1 %not-slash))
 142                   (file2 (string-tokenize file2 %not-slash)))
 143          (match file1
 144            (()
 145             #t)
 146            ((head1 tail1 ...)
 147             (match file2
 148               ((head2 tail2 ...)
 149                (and (string=? head1 head2) (loop tail1 tail2)))
 150               (()
 151                #f)))))))
 152
 153 (define (file-system-needed-for-boot? fs)
 154   "Return true if FS has the 'needed-for-boot?' flag set, or if it holds the
 155 store--e.g., if FS is the root file system."
 156   (or (%file-system-needed-for-boot? fs)
 157       (and (file-prefix? (file-system-mount-point fs) (%store-prefix))
 158            (not (memq 'bind-mount (file-system-flags fs))))))
 159
 160 (define (file-system->spec fs)
 161   "Return a list corresponding to file-system FS that can be passed to the
 162 initrd code."
 163   (match fs
 164     (($ <file-system> device title mount-point type flags options _ _ check?)
 165      (list (if (uuid? device)
 166                `(uuid ,(uuid-type device) ,(uuid-bytevector device))
 167                device)
 168            title mount-point type flags options check?))))
 169
 170 (define (spec->file-system sexp)
 171   "Deserialize SEXP, a list, to the corresponding <file-system> object."
 172   (match sexp
 173     ((device title mount-point type flags options check?)
 174      (file-system
 175        (device (match device
 176                  (('uuid (? symbol? type) (? bytevector? bv))
 177                   (bytevector->uuid bv type))
 178                  (_
 179                   device)))
 180        (title title)
 181        (mount-point mount-point) (type type)
 182        (flags flags) (options options)
 183        (check? check?)))))
 184
 185 (define (specification->file-system-mapping spec writable?)
 186   "Read the SPEC and return the corresponding <file-system-mapping>.  SPEC is
 187 a string of the form \"SOURCE\" or \"SOURCE=TARGET\".  The former specifies
 188 that SOURCE from the host should be mounted at SOURCE in the other system.
 189 The latter format specifies that SOURCE from the host should be mounted at
 190 TARGET in the other system."
 191   (let ((index (string-index spec #\=)))
 192     (if index
 193         (file-system-mapping
 194          (source (substring spec 0 index))
 195          (target (substring spec (+ 1 index)))
 196          (writable? writable?))
 197         (file-system-mapping
 198          (source spec)
 199          (target spec)
 200          (writable? writable?)))))
 201
 202 \f
 203 ;;;
 204 ;;; Common file systems.
 205 ;;;
 206
 207 (define %pseudo-file-system-types
 208   ;; List of know pseudo file system types.  This is used when validating file
 209   ;; system definitions.
 210   '("binfmt_misc" "cgroup" "debugfs" "devpts" "devtmpfs" "efivarfs" "fusectl"
 211     "hugetlbfs" "overlay" "proc" "securityfs" "sysfs" "tmpfs"))
 212
 213 (define %fuse-control-file-system
 214   ;; Control file system for Linux' file systems in user-space (FUSE).
 215   (file-system
 216     (device "fusectl")
 217     (mount-point "/sys/fs/fuse/connections")
 218     (type "fusectl")
 219     (check? #f)))
 220
 221 (define %binary-format-file-system
 222   ;; Support for arbitrary executable binary format.
 223   (file-system
 224     (device "binfmt_misc")
 225     (mount-point "/proc/sys/fs/binfmt_misc")
 226     (type "binfmt_misc")
 227     (check? #f)))
 228
 229 (define %tty-gid
 230   ;; ID of the 'tty' group.  Allocate it statically to make it easy to refer
 231   ;; to it from here and from the 'tty' group definitions.
 232   996)
 233
 234 (define %pseudo-terminal-file-system
 235   ;; The pseudo-terminal file system.  It needs to be mounted so that
 236   ;; statfs(2) returns DEVPTS_SUPER_MAGIC like libc's getpt(3) expects (and
 237   ;; thus openpty(3) and its users, such as xterm.)
 238   (file-system
 239     (device "none")
 240     (mount-point "/dev/pts")
 241     (type "devpts")
 242     (check? #f)
 243     (needed-for-boot? #f)
 244     (create-mount-point? #t)
 245     (options (string-append "gid=" (number->string %tty-gid) ",mode=620"))))
 246
 247 (define %shared-memory-file-system
 248   ;; Shared memory.
 249   (file-system
 250     (device "tmpfs")
 251     (mount-point "/dev/shm")
 252     (type "tmpfs")
 253     (check? #f)
 254     (flags '(no-suid no-dev))
 255     (options "size=50%")                         ;TODO: make size configurable
 256     (create-mount-point? #t)))
 257
 258 (define %immutable-store
 259   ;; Read-only store to avoid users or daemons accidentally modifying it.
 260   ;; 'guix-daemon' has provisions to remount it read-write in its own name
 261   ;; space.
 262   (file-system
 263     (device (%store-prefix))
 264     (mount-point (%store-prefix))
 265     (type "none")
 266     (check? #f)
 267     (flags '(read-only bind-mount))))
 268
 269 (define %control-groups
 270   (let ((parent (file-system
 271                   (device "cgroup")
 272                   (mount-point "/sys/fs/cgroup")
 273                   (type "tmpfs")
 274                   (check? #f))))
 275     (cons parent
 276           (map (lambda (subsystem)
 277                  (file-system
 278                    (device "cgroup")
 279                    (mount-point (string-append "/sys/fs/cgroup/" subsystem))
 280                    (type "cgroup")
 281                    (check? #f)
 282                    (options subsystem)
 283                    (create-mount-point? #t)
 284
 285                    ;; This must be mounted after, and unmounted before the
 286                    ;; parent directory.
 287                    (dependencies (list parent))))
 288                '("cpuset" "cpu" "cpuacct" "memory" "devices" "freezer"
 289                  "blkio" "perf_event")))))
 290
 291 (define %elogind-file-systems
 292   ;; We don't use systemd, but these file systems are needed for elogind,
 293   ;; which was extracted from systemd.
 294   (append
 295    (list (file-system
 296            (device "none")
 297            (mount-point "/run/systemd")
 298            (type "tmpfs")
 299            (check? #f)
 300            (flags '(no-suid no-dev no-exec))
 301            (options "mode=0755")
 302            (create-mount-point? #t))
 303          (file-system
 304            (device "none")
 305            (mount-point "/run/user")
 306            (type "tmpfs")
 307            (check? #f)
 308            (flags '(no-suid no-dev no-exec))
 309            (options "mode=0755")
 310            (create-mount-point? #t))
 311          ;; Elogind uses cgroups to organize processes, allowing it to map PIDs
 312          ;; to sessions.  Elogind's cgroup hierarchy isn't associated with any
 313          ;; resource controller ("subsystem").
 314          (file-system
 315            (device "cgroup")
 316            (mount-point "/sys/fs/cgroup/elogind")
 317            (type "cgroup")
 318            (check? #f)
 319            (options "none,name=elogind")
 320            (create-mount-point? #t)
 321            (dependencies (list (car %control-groups)))))
 322    %control-groups))
 323
 324 (define %base-file-systems
 325   ;; List of basic file systems to be mounted.  Note that /proc and /sys are
 326   ;; currently mounted by the initrd.
 327   (list %pseudo-terminal-file-system
 328         %shared-memory-file-system
 329         %immutable-store))
 330
 331 ;; File systems for Linux containers differ from %base-file-systems in that
 332 ;; they impose additional restrictions such as no-exec or need different
 333 ;; options to function properly.
 334 ;;
 335 ;; The file system flags and options conform to the libcontainer
 336 ;; specification:
 337 ;; https://github.com/docker/libcontainer/blob/master/SPEC.md#filesystem
 338 (define %container-file-systems
 339   (list
 340    ;; Pseudo-terminal file system.
 341    (file-system
 342      (device "none")
 343      (mount-point "/dev/pts")
 344      (type "devpts")
 345      (flags '(no-exec no-suid))
 346      (needed-for-boot? #t)
 347      (create-mount-point? #t)
 348      (check? #f)
 349      (options "newinstance,ptmxmode=0666,mode=620"))
 350    ;; Shared memory file system.
 351    (file-system
 352      (device "tmpfs")
 353      (mount-point "/dev/shm")
 354      (type "tmpfs")
 355      (flags '(no-exec no-suid no-dev))
 356      (options "mode=1777,size=65536k")
 357      (needed-for-boot? #t)
 358      (create-mount-point? #t)
 359      (check? #f))
 360    ;; Message queue file system.
 361    (file-system
 362      (device "mqueue")
 363      (mount-point "/dev/mqueue")
 364      (type "mqueue")
 365      (flags '(no-exec no-suid no-dev))
 366      (needed-for-boot? #t)
 367      (create-mount-point? #t)
 368      (check? #f))))
 369
 370 \f
 371 ;;;
 372 ;;; Shared file systems, for VMs/containers.
 373 ;;;
 374
 375 ;; Mapping of host file system SOURCE to mount point TARGET in the guest.
 376 (define-record-type* <file-system-mapping> file-system-mapping
 377   make-file-system-mapping
 378   file-system-mapping?
 379   (source    file-system-mapping-source)          ;string
 380   (target    file-system-mapping-target)          ;string
 381   (writable? file-system-mapping-writable?        ;Boolean
 382              (default #f)))
 383
 384 (define (file-system-mapping->bind-mount mapping)
 385   "Return a file system that realizes MAPPING, a <file-system-mapping>, using
 386 a bind mount."
 387   (match mapping
 388     (($ <file-system-mapping> source target writable?)
 389      (file-system
 390        (mount-point target)
 391        (device source)
 392        (type "none")
 393        (flags (if writable?
 394                   '(bind-mount)
 395                   '(bind-mount read-only)))
 396        (check? #f)
 397        (create-mount-point? #t)))))
 398
 399 (define %store-mapping
 400   ;; Mapping of the host's store into the guest.
 401   (file-system-mapping
 402    (source (%store-prefix))
 403    (target (%store-prefix))
 404    (writable? #f)))
 405
 406 (define %network-configuration-files
 407   ;; List of essential network configuration files.
 408   '("/etc/resolv.conf"
 409     "/etc/nsswitch.conf"
 410     "/etc/services"
 411     "/etc/hosts"))
 412
 413 (define %network-file-mappings
 414   ;; List of file mappings for essential network files.
 415   (filter-map (lambda (file)
 416                 (file-system-mapping
 417                  (source file)
 418                  (target file)
 419                  ;; XXX: On some GNU/Linux systems, /etc/resolv.conf is a
 420                  ;; symlink to a file in a tmpfs which, for an unknown reason,
 421                  ;; cannot be bind mounted read-only within the container.
 422                  (writable? (string=? file "/etc/resolv.conf"))))
 423               %network-configuration-files))
 424
 425 (define (file-system-type-predicate type)
 426   "Return a predicate that, when passed a file system, returns #t if that file
 427 system has the given TYPE."
 428   (lambda (fs)
 429     (string=? (file-system-type fs) type)))
 430
 431 ;;; file-systems.scm ends here