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