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