1 ;;; GNU Guix --- Functional package management for GNU
2 ;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
4 ;;; This file is part of GNU Guix.
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.
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.
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/>.
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 (srfi srfi-9)
24 #:use-module (srfi srfi-9 gnu)
25 #:use-module (guix records)
26 #:use-module (gnu system uuid)
27 #:re-export (uuid ;backward compatibility
33 file-system-title ;deprecated
34 file-system-mount-point
36 file-system-needed-for-boot?
41 file-system-create-mount-point?
42 file-system-dependencies
45 file-system-type-predicate
49 file-system-label->string
53 specification->file-system-mapping
55 %pseudo-file-system-types
56 %fuse-control-file-system
57 %binary-format-file-system
58 %shared-memory-file-system
59 %pseudo-terminal-file-system
66 %container-file-systems
71 file-system-mapping-source
72 file-system-mapping-target
73 file-system-mapping-writable?
75 file-system-mapping->bind-mount
78 %network-configuration-files
79 %network-file-mappings))
83 ;;; Declaring file systems to be mounted.
85 ;;; Note: this file system is used both in the Shepherd and on the "host
86 ;;; side", so it must not include (gnu packages …) modules.
90 ;; File system declaration.
91 (define-record-type* <file-system> %file-system
94 (device file-system-device) ; string | <uuid> | <file-system-label>
95 (mount-point file-system-mount-point) ; string
96 (type file-system-type) ; string
97 (flags file-system-flags ; list of symbols
99 (options file-system-options ; string or #f
101 (mount? file-system-mount? ; Boolean
103 (needed-for-boot? %file-system-needed-for-boot? ; Boolean
105 (check? file-system-check? ; Boolean
107 (create-mount-point? file-system-create-mount-point? ; Boolean
109 (dependencies file-system-dependencies ; list of <file-system>
110 (default '())) ; or <mapped-device>
111 (location file-system-location
112 (default (current-source-location))
115 ;; A file system label for use in the 'device' field.
116 (define-record-type <file-system-label>
117 (file-system-label label)
119 (label file-system-label->string))
121 (set-record-type-printer! <file-system-label>
123 (format port "#<file-system-label ~s>"
124 (file-system-label->string obj))))
126 (define-syntax report-deprecation
128 "Report the use of the now-deprecated 'title' field."
131 (let* ((source (syntax-source #'field))
132 (file (and source (assq-ref source 'filename)))
134 (and=> (assq-ref source 'line) 1+)))
135 (column (and source (assq-ref source 'column))))
136 (format (current-error-port)
137 "~a:~a:~a: warning: 'title' field is deprecated~%"
141 ;; Helper for 'process-file-system-declaration'.
142 (define-syntax device-expression
143 (syntax-rules (quote label uuid device)
144 ((_ (quote label) dev)
145 (file-system-label dev))
146 ((_ (quote uuid) dev)
147 (if (uuid? dev) dev (uuid dev)))
148 ((_ (quote device) dev)
152 ((label) (file-system-label dev))
156 ;; Helper to interpret the now-deprecated 'title' field. Detect forms like
157 ;; (title 'label), remove them, and adjust the 'device' field accordingly.
158 ;; TODO: Remove this once 'title' has been deprecated long enough.
159 (define-syntax process-file-system-declaration
160 (syntax-rules (device title)
161 ((_ () (rest ...) #f #f) ;no 'title' and no 'device' field
162 (%file-system rest ...))
163 ((_ () (rest ...) dev #f) ;no 'title' field
164 (%file-system rest ... (device dev)))
165 ((_ () (rest ...) dev titl) ;got a 'title' field
166 (%file-system rest ...
167 (device (device-expression titl dev))))
168 ((_ ((title titl) rest ...) (previous ...) dev _)
170 (report-deprecation (title titl))
171 (process-file-system-declaration (rest ...)
174 ((_ ((device dev) rest ...) (previous ...) _ titl)
175 (process-file-system-declaration (rest ...)
178 ((_ (field rest ...) (previous ...) dev titl)
179 (process-file-system-declaration (rest ...)
183 (define-syntax-rule (file-system fields ...)
184 (process-file-system-declaration (fields ...) () #f #f))
186 (define (file-system-title fs) ;deprecated
187 (match (file-system-device fs)
188 ((? file-system-label?) 'label)
190 ((? string?) 'device)))
192 ;; Note: This module is used both on the build side and on the host side.
193 ;; Arrange not to pull (guix store) and (guix config) because the latter
194 ;; differs from user to user.
195 (define (%store-prefix)
196 "Return the store prefix."
197 ;; Note: If we have (guix store database) in the search path and we do *not*
198 ;; have (guix store) proper, 'resolve-module' returns an empty (guix store)
199 ;; with one sub-module.
200 (cond ((and=> (resolve-module '(guix store) #:ensure #f)
202 (module-variable store '%store-prefix)))
205 ((variable-ref variable))))
206 ((getenv "NIX_STORE")
212 (char-set-complement (char-set #\/)))
214 (define (file-prefix? file1 file2)
215 "Return #t if FILE1 denotes the name of a file that is a parent of FILE2,
216 where both FILE1 and FILE2 are absolute file name. For example:
218 (file-prefix? \"/gnu\" \"/gnu/store\")
221 (file-prefix? \"/gn\" \"/gnu/store\")
224 (and (string-prefix? "/" file1)
225 (string-prefix? "/" file2)
226 (let loop ((file1 (string-tokenize file1 %not-slash))
227 (file2 (string-tokenize file2 %not-slash)))
234 (and (string=? head1 head2) (loop tail1 tail2)))
238 (define (file-system-needed-for-boot? fs)
239 "Return true if FS has the 'needed-for-boot?' flag set, or if it holds the
240 store--e.g., if FS is the root file system."
241 (or (%file-system-needed-for-boot? fs)
242 (and (file-prefix? (file-system-mount-point fs) (%store-prefix))
243 (not (memq 'bind-mount (file-system-flags fs))))))
245 (define (file-system->spec fs)
246 "Return a list corresponding to file-system FS that can be passed to the
249 (($ <file-system> device mount-point type flags options _ _ check?)
250 (list (cond ((uuid? device)
251 `(uuid ,(uuid-type device) ,(uuid-bytevector device)))
252 ((file-system-label? device)
253 `(file-system-label ,(file-system-label->string device)))
255 mount-point type flags options check?))))
257 (define (spec->file-system sexp)
258 "Deserialize SEXP, a list, to the corresponding <file-system> object."
260 ((device mount-point type flags options check?)
262 (device (match device
263 (('uuid (? symbol? type) (? bytevector? bv))
264 (bytevector->uuid bv type))
265 (('file-system-label (? string? label))
266 (file-system-label label))
269 (mount-point mount-point) (type type)
270 (flags flags) (options options)
273 (define (specification->file-system-mapping spec writable?)
274 "Read the SPEC and return the corresponding <file-system-mapping>. SPEC is
275 a string of the form \"SOURCE\" or \"SOURCE=TARGET\". The former specifies
276 that SOURCE from the host should be mounted at SOURCE in the other system.
277 The latter format specifies that SOURCE from the host should be mounted at
278 TARGET in the other system."
279 (let ((index (string-index spec #\=)))
282 (source (substring spec 0 index))
283 (target (substring spec (+ 1 index)))
284 (writable? writable?))
288 (writable? writable?)))))
292 ;;; Common file systems.
295 (define %pseudo-file-system-types
296 ;; List of know pseudo file system types. This is used when validating file
297 ;; system definitions.
298 '("binfmt_misc" "cgroup" "debugfs" "devpts" "devtmpfs" "efivarfs" "fusectl"
299 "hugetlbfs" "overlay" "proc" "securityfs" "sysfs" "tmpfs"))
301 (define %fuse-control-file-system
302 ;; Control file system for Linux' file systems in user-space (FUSE).
305 (mount-point "/sys/fs/fuse/connections")
309 (define %binary-format-file-system
310 ;; Support for arbitrary executable binary format.
312 (device "binfmt_misc")
313 (mount-point "/proc/sys/fs/binfmt_misc")
318 ;; ID of the 'tty' group. Allocate it statically to make it easy to refer
319 ;; to it from here and from the 'tty' group definitions.
322 (define %pseudo-terminal-file-system
323 ;; The pseudo-terminal file system. It needs to be mounted so that
324 ;; statfs(2) returns DEVPTS_SUPER_MAGIC like libc's getpt(3) expects (and
325 ;; thus openpty(3) and its users, such as xterm.)
328 (mount-point "/dev/pts")
331 (needed-for-boot? #f)
332 (create-mount-point? #t)
333 (options (string-append "gid=" (number->string %tty-gid) ",mode=620"))))
335 (define %shared-memory-file-system
339 (mount-point "/dev/shm")
342 (flags '(no-suid no-dev))
343 (options "size=50%") ;TODO: make size configurable
344 (create-mount-point? #t)))
346 (define %immutable-store
347 ;; Read-only store to avoid users or daemons accidentally modifying it.
348 ;; 'guix-daemon' has provisions to remount it read-write in its own name
351 (device (%store-prefix))
352 (mount-point (%store-prefix))
355 (flags '(read-only bind-mount))))
357 (define %control-groups
358 (let ((parent (file-system
360 (mount-point "/sys/fs/cgroup")
364 (map (lambda (subsystem)
367 (mount-point (string-append "/sys/fs/cgroup/" subsystem))
371 (create-mount-point? #t)
373 ;; This must be mounted after, and unmounted before the
375 (dependencies (list parent))))
376 '("cpuset" "cpu" "cpuacct" "memory" "devices" "freezer"
377 "blkio" "perf_event")))))
379 (define %elogind-file-systems
380 ;; We don't use systemd, but these file systems are needed for elogind,
381 ;; which was extracted from systemd.
385 (mount-point "/run/systemd")
388 (flags '(no-suid no-dev no-exec))
389 (options "mode=0755")
390 (create-mount-point? #t))
393 (mount-point "/run/user")
396 (flags '(no-suid no-dev no-exec))
397 (options "mode=0755")
398 (create-mount-point? #t))
399 ;; Elogind uses cgroups to organize processes, allowing it to map PIDs
400 ;; to sessions. Elogind's cgroup hierarchy isn't associated with any
401 ;; resource controller ("subsystem").
404 (mount-point "/sys/fs/cgroup/elogind")
407 (options "none,name=elogind")
408 (create-mount-point? #t)
409 (dependencies (list (car %control-groups)))))
412 (define %base-file-systems
413 ;; List of basic file systems to be mounted. Note that /proc and /sys are
414 ;; currently mounted by the initrd.
415 (list %pseudo-terminal-file-system
416 %shared-memory-file-system
419 ;; File systems for Linux containers differ from %base-file-systems in that
420 ;; they impose additional restrictions such as no-exec or need different
421 ;; options to function properly.
423 ;; The file system flags and options conform to the libcontainer
425 ;; https://github.com/docker/libcontainer/blob/master/SPEC.md#filesystem
426 (define %container-file-systems
428 ;; Pseudo-terminal file system.
431 (mount-point "/dev/pts")
433 (flags '(no-exec no-suid))
434 (needed-for-boot? #t)
435 (create-mount-point? #t)
437 (options "newinstance,ptmxmode=0666,mode=620"))
438 ;; Shared memory file system.
441 (mount-point "/dev/shm")
443 (flags '(no-exec no-suid no-dev))
444 (options "mode=1777,size=65536k")
445 (needed-for-boot? #t)
446 (create-mount-point? #t)
448 ;; Message queue file system.
451 (mount-point "/dev/mqueue")
453 (flags '(no-exec no-suid no-dev))
454 (needed-for-boot? #t)
455 (create-mount-point? #t)
460 ;;; Shared file systems, for VMs/containers.
463 ;; Mapping of host file system SOURCE to mount point TARGET in the guest.
464 (define-record-type* <file-system-mapping> file-system-mapping
465 make-file-system-mapping
467 (source file-system-mapping-source) ;string
468 (target file-system-mapping-target) ;string
469 (writable? file-system-mapping-writable? ;Boolean
472 (define (file-system-mapping->bind-mount mapping)
473 "Return a file system that realizes MAPPING, a <file-system-mapping>, using
476 (($ <file-system-mapping> source target writable?)
483 '(bind-mount read-only)))
485 (create-mount-point? #t)))))
487 (define %store-mapping
488 ;; Mapping of the host's store into the guest.
490 (source (%store-prefix))
491 (target (%store-prefix))
494 (define %network-configuration-files
495 ;; List of essential network configuration files.
501 (define %network-file-mappings
502 ;; List of file mappings for essential network files.
503 (filter-map (lambda (file)
507 ;; XXX: On some GNU/Linux systems, /etc/resolv.conf is a
508 ;; symlink to a file in a tmpfs which, for an unknown reason,
509 ;; cannot be bind mounted read-only within the container.
510 (writable? (string=? file "/etc/resolv.conf"))))
511 %network-configuration-files))
513 (define (file-system-type-predicate type)
514 "Return a predicate that, when passed a file system, returns #t if that file
515 system has the given TYPE."
517 (string=? (file-system-type fs) type)))
519 ;;; file-systems.scm ends here