gnu/system/file-systems.scm

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