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