gnu/system/file-systems.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2013, 2014, 2015 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 (ice-9 regex)
  22   #:use-module (guix gexp)
  23   #:use-module (guix records)
  24   #:use-module (guix store)
  25   #:use-module (rnrs bytevectors)
  26   #:use-module ((gnu build file-systems) #:select (uuid->string))
  27   #:re-export (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-check?
  39             file-system-create-mount-point?
  40             file-system-dependencies
  41
  42             file-system->spec
  43             string->uuid
  44             uuid
  45
  46             %fuse-control-file-system
  47             %binary-format-file-system
  48             %shared-memory-file-system
  49             %pseudo-terminal-file-system
  50             %immutable-store
  51             %control-groups
  52             %elogind-file-systems
  53
  54             %base-file-systems
  55             %container-file-systems
  56
  57             mapped-device
  58             mapped-device?
  59             mapped-device-source
  60             mapped-device-target
  61             mapped-device-type
  62
  63             mapped-device-kind
  64             mapped-device-kind?
  65             mapped-device-kind-open
  66             mapped-device-kind-close
  67
  68             <file-system-mapping>
  69             file-system-mapping
  70             file-system-mapping?
  71             file-system-mapping-source
  72             file-system-mapping-target
  73             file-system-mapping-writable?
  74
  75             %store-mapping))
  76
  77 ;;; Commentary:
  78 ;;;
  79 ;;; Declaring file systems to be mounted.
  80 ;;;
  81 ;;; Code:
  82
  83 ;; File system declaration.
  84 (define-record-type* <file-system> file-system
  85   make-file-system
  86   file-system?
  87   (device           file-system-device)           ; string
  88   (title            file-system-title             ; 'device | 'label | 'uuid
  89                     (default 'device))
  90   (mount-point      file-system-mount-point)      ; string
  91   (type             file-system-type)             ; string
  92   (flags            file-system-flags             ; list of symbols
  93                     (default '()))
  94   (options          file-system-options           ; string or #f
  95                     (default #f))
  96   (needed-for-boot? %file-system-needed-for-boot? ; Boolean
  97                     (default #f))
  98   (check?           file-system-check?            ; Boolean
  99                     (default #t))
 100   (create-mount-point? file-system-create-mount-point? ; Boolean
 101                        (default #f))
 102   (dependencies     file-system-dependencies      ; list of <file-system>
 103                     (default '())))               ; or <mapped-device>
 104
 105 (define-inlinable (file-system-needed-for-boot? fs)
 106   "Return true if FS has the 'needed-for-boot?' flag set, or if it's the root
 107 file system."
 108   (or (%file-system-needed-for-boot? fs)
 109       (string=? "/" (file-system-mount-point fs))))
 110
 111 (define (file-system->spec fs)
 112   "Return a list corresponding to file-system FS that can be passed to the
 113 initrd code."
 114   (match fs
 115     (($ <file-system> device title mount-point type flags options _ check?)
 116      (list device title mount-point type flags options check?))))
 117
 118 (define %uuid-rx
 119   ;; The regexp of a UUID.
 120   (make-regexp "^([[:xdigit:]]{8})-([[:xdigit:]]{4})-([[:xdigit:]]{4})-([[:xdigit:]]{4})-([[:xdigit:]]{12})$"))
 121
 122 (define (string->uuid str)
 123   "Parse STR as a DCE UUID (see <https://tools.ietf.org/html/rfc4122>) and
 124 return its contents as a 16-byte bytevector.  Return #f if STR is not a valid
 125 UUID representation."
 126   (and=> (regexp-exec %uuid-rx str)
 127          (lambda (match)
 128            (letrec-syntax ((hex->number
 129                             (syntax-rules ()
 130                               ((_ index)
 131                                (string->number (match:substring match index)
 132                                                16))))
 133                            (put!
 134                             (syntax-rules ()
 135                               ((_ bv index (number len) rest ...)
 136                                (begin
 137                                  (bytevector-uint-set! bv index number
 138                                                        (endianness big) len)
 139                                  (put! bv (+ index len) rest ...)))
 140                               ((_ bv index)
 141                                bv))))
 142              (let ((time-low  (hex->number 1))
 143                    (time-mid  (hex->number 2))
 144                    (time-hi   (hex->number 3))
 145                    (clock-seq (hex->number 4))
 146                    (node      (hex->number 5))
 147                    (uuid      (make-bytevector 16)))
 148                (put! uuid 0
 149                      (time-low 4) (time-mid 2) (time-hi 2)
 150                      (clock-seq 2) (node 6)))))))
 151
 152 (define-syntax uuid
 153   (lambda (s)
 154     "Return the bytevector corresponding to the given UUID representation."
 155     (syntax-case s ()
 156       ((_ str)
 157        (string? (syntax->datum #'str))
 158        ;; A literal string: do the conversion at expansion time.
 159        (let ((bv (string->uuid (syntax->datum #'str))))
 160          (unless bv
 161            (syntax-violation 'uuid "invalid UUID" s))
 162          (datum->syntax #'str bv)))
 163       ((_ str)
 164        #'(string->uuid str)))))
 165
 166 \f
 167 ;;;
 168 ;;; Common file systems.
 169 ;;;
 170
 171 (define %fuse-control-file-system
 172   ;; Control file system for Linux' file systems in user-space (FUSE).
 173   (file-system
 174     (device "fusectl")
 175     (mount-point "/sys/fs/fuse/connections")
 176     (type "fusectl")
 177     (check? #f)))
 178
 179 (define %binary-format-file-system
 180   ;; Support for arbitrary executable binary format.
 181   (file-system
 182     (device "binfmt_misc")
 183     (mount-point "/proc/sys/fs/binfmt_misc")
 184     (type "binfmt_misc")
 185     (check? #f)))
 186
 187 (define %tty-gid
 188   ;; ID of the 'tty' group.  Allocate it statically to make it easy to refer
 189   ;; to it from here and from the 'tty' group definitions.
 190   996)
 191
 192 (define %pseudo-terminal-file-system
 193   ;; The pseudo-terminal file system.  It needs to be mounted so that
 194   ;; statfs(2) returns DEVPTS_SUPER_MAGIC like libc's getpt(3) expects (and
 195   ;; thus openpty(3) and its users, such as xterm.)
 196   (file-system
 197     (device "none")
 198     (mount-point "/dev/pts")
 199     (type "devpts")
 200     (check? #f)
 201     (needed-for-boot? #f)
 202     (create-mount-point? #t)
 203     (options (string-append "gid=" (number->string %tty-gid) ",mode=620"))))
 204
 205 (define %shared-memory-file-system
 206   ;; Shared memory.
 207   (file-system
 208     (device "tmpfs")
 209     (mount-point "/dev/shm")
 210     (type "tmpfs")
 211     (check? #f)
 212     (flags '(no-suid no-dev))
 213     (options "size=50%")                         ;TODO: make size configurable
 214     (create-mount-point? #t)))
 215
 216 (define %immutable-store
 217   ;; Read-only store to avoid users or daemons accidentally modifying it.
 218   ;; 'guix-daemon' has provisions to remount it read-write in its own name
 219   ;; space.
 220   (file-system
 221     (device (%store-prefix))
 222     (mount-point (%store-prefix))
 223     (type "none")
 224     (check? #f)
 225     (flags '(read-only bind-mount))))
 226
 227 (define %control-groups
 228   (let ((parent (file-system
 229                   (device "cgroup")
 230                   (mount-point "/sys/fs/cgroup")
 231                   (type "tmpfs")
 232                   (check? #f))))
 233     (cons parent
 234           (map (lambda (subsystem)
 235                  (file-system
 236                    (device "cgroup")
 237                    (mount-point (string-append "/sys/fs/cgroup/" subsystem))
 238                    (type "cgroup")
 239                    (check? #f)
 240                    (options subsystem)
 241                    (create-mount-point? #t)
 242
 243                    ;; This must be mounted after, and unmounted before the
 244                    ;; parent directory.
 245                    (dependencies (list parent))))
 246                '("cpuset" "cpu" "cpuacct" "memory" "devices" "freezer"
 247                  "blkio" "perf_event" "hugetlb")))))
 248
 249 (define %elogind-file-systems
 250   ;; We don't use systemd, but these file systems are needed for elogind,
 251   ;; which was extracted from systemd.
 252   (list (file-system
 253           (device "none")
 254           (mount-point "/run/systemd")
 255           (type "tmpfs")
 256           (check? #f)
 257           (flags '(no-suid no-dev no-exec))
 258           (options "mode=0755")
 259           (create-mount-point? #t))
 260         (file-system
 261           (device "none")
 262           (mount-point "/run/user")
 263           (type "tmpfs")
 264           (check? #f)
 265           (flags '(no-suid no-dev no-exec))
 266           (options "mode=0755")
 267           (create-mount-point? #t))))
 268
 269 (define %base-file-systems
 270   ;; List of basic file systems to be mounted.  Note that /proc and /sys are
 271   ;; currently mounted by the initrd.
 272   (append (list %pseudo-terminal-file-system
 273                 %shared-memory-file-system
 274                 %immutable-store)
 275           %elogind-file-systems
 276           %control-groups))
 277
 278 ;; File systems for Linux containers differ from %base-file-systems in that
 279 ;; they impose additional restrictions such as no-exec or need different
 280 ;; options to function properly.
 281 ;;
 282 ;; The file system flags and options conform to the libcontainer
 283 ;; specification:
 284 ;; https://github.com/docker/libcontainer/blob/master/SPEC.md#filesystem
 285 (define %container-file-systems
 286   (list
 287    ;; Pseudo-terminal file system.
 288    (file-system
 289      (device "none")
 290      (mount-point "/dev/pts")
 291      (type "devpts")
 292      (flags '(no-exec no-suid))
 293      (needed-for-boot? #t)
 294      (create-mount-point? #t)
 295      (check? #f)
 296      (options "newinstance,ptmxmode=0666,mode=620"))
 297    ;; Shared memory file system.
 298    (file-system
 299      (device "tmpfs")
 300      (mount-point "/dev/shm")
 301      (type "tmpfs")
 302      (flags '(no-exec no-suid no-dev))
 303      (options "mode=1777,size=65536k")
 304      (needed-for-boot? #t)
 305      (create-mount-point? #t)
 306      (check? #f))
 307    ;; Message queue file system.
 308    (file-system
 309      (device "mqueue")
 310      (mount-point "/dev/mqueue")
 311      (type "mqueue")
 312      (flags '(no-exec no-suid no-dev))
 313      (needed-for-boot? #t)
 314      (create-mount-point? #t)
 315      (check? #f))))
 316
 317
 318 \f
 319 ;;;
 320 ;;; Mapped devices, for Linux's device-mapper.
 321 ;;;
 322
 323 (define-record-type* <mapped-device> mapped-device
 324   make-mapped-device
 325   mapped-device?
 326   (source    mapped-device-source)                ;string
 327   (target    mapped-device-target)                ;string
 328   (type      mapped-device-type))                 ;<mapped-device-kind>
 329
 330 (define-record-type* <mapped-device-type> mapped-device-kind
 331   make-mapped-device-kind
 332   mapped-device-kind?
 333   (open      mapped-device-kind-open)             ;source target -> gexp
 334   (close     mapped-device-kind-close             ;source target -> gexp
 335              (default (const #~(const #f)))))
 336
 337 \f
 338 ;;;
 339 ;;; Shared file systems, for VMs/containers.
 340 ;;;
 341
 342 ;; Mapping of host file system SOURCE to mount point TARGET in the guest.
 343 (define-record-type* <file-system-mapping> file-system-mapping
 344   make-file-system-mapping
 345   file-system-mapping?
 346   (source    file-system-mapping-source)          ;string
 347   (target    file-system-mapping-target)          ;string
 348   (writable? file-system-mapping-writable?        ;Boolean
 349              (default #f)))
 350
 351 (define %store-mapping
 352   ;; Mapping of the host's store into the guest.
 353   (file-system-mapping
 354    (source (%store-prefix))
 355    (target (%store-prefix))
 356    (writable? #f)))
 357
 358 ;;; file-systems.scm ends here