;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2013, 2014 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(define-module (gnu system file-systems)
- #:use-module (guix gexp)
+ #:use-module (ice-9 match)
+ #:use-module (rnrs bytevectors)
+ #:use-module (srfi srfi-1)
#:use-module (guix records)
+ #:use-module (gnu system uuid)
+ #:re-export (uuid ;backward compatibility
+ string->uuid
+ uuid->string)
#:export (<file-system>
file-system
file-system?
file-system-needed-for-boot?
file-system-flags
file-system-options
+ file-system-mount?
file-system-check?
file-system-create-mount-point?
+ file-system-dependencies
+ file-system-location
+
+ file-system-type-predicate
+
+ file-system->spec
+ spec->file-system
+ specification->file-system-mapping
%fuse-control-file-system
%binary-format-file-system
%shared-memory-file-system
%pseudo-terminal-file-system
- %devtmpfs-file-system
+ %tty-gid
+ %immutable-store
+ %control-groups
+ %elogind-file-systems
%base-file-systems
+ %container-file-systems
+
+ <file-system-mapping>
+ file-system-mapping
+ file-system-mapping?
+ file-system-mapping-source
+ file-system-mapping-target
+ file-system-mapping-writable?
- mapped-device
- mapped-device?
- mapped-device-source
- mapped-device-target
- mapped-device-type
+ file-system-mapping->bind-mount
- mapped-device-kind
- mapped-device-kind?
- mapped-device-kind-open
- mapped-device-kind-close))
+ %store-mapping
+ %network-configuration-files
+ %network-file-mappings))
;;; Commentary:
;;;
;;; Declaring file systems to be mounted.
;;;
+;;; Note: this file system is used both in the Shepherd and on the "host
+;;; side", so it must not include (gnu packages …) modules.
+;;;
;;; Code:
;; File system declaration.
(default '()))
(options file-system-options ; string or #f
(default #f))
+ (mount? file-system-mount? ; Boolean
+ (default #t))
(needed-for-boot? %file-system-needed-for-boot? ; Boolean
(default #f))
(check? file-system-check? ; Boolean
(default #t))
(create-mount-point? file-system-create-mount-point? ; Boolean
- (default #f)))
+ (default #f))
+ (dependencies file-system-dependencies ; list of <file-system>
+ (default '())) ; or <mapped-device>
+ (location file-system-location
+ (default (current-source-location))
+ (innate)))
+
+;; Note: This module is used both on the build side and on the host side.
+;; Arrange not to pull (guix store) and (guix config) because the latter
+;; differs from user to user.
+(define (%store-prefix)
+ "Return the store prefix."
+ (cond ((resolve-module '(guix store) #:ensure #f)
+ =>
+ (lambda (store)
+ ((module-ref store '%store-prefix))))
+ ((getenv "NIX_STORE")
+ => identity)
+ (else
+ "/gnu/store")))
+
+(define %not-slash
+ (char-set-complement (char-set #\/)))
+
+(define (file-prefix? file1 file2)
+ "Return #t if FILE1 denotes the name of a file that is a parent of FILE2,
+where both FILE1 and FILE2 are absolute file name. For example:
+
+ (file-prefix? \"/gnu\" \"/gnu/store\")
+ => #t
-(define-inlinable (file-system-needed-for-boot? fs)
- "Return true if FS has the 'needed-for-boot?' flag set, or if it's the root
-file system."
+ (file-prefix? \"/gn\" \"/gnu/store\")
+ => #f
+"
+ (and (string-prefix? "/" file1)
+ (string-prefix? "/" file2)
+ (let loop ((file1 (string-tokenize file1 %not-slash))
+ (file2 (string-tokenize file2 %not-slash)))
+ (match file1
+ (()
+ #t)
+ ((head1 tail1 ...)
+ (match file2
+ ((head2 tail2 ...)
+ (and (string=? head1 head2) (loop tail1 tail2)))
+ (()
+ #f)))))))
+
+(define (file-system-needed-for-boot? fs)
+ "Return true if FS has the 'needed-for-boot?' flag set, or if it holds the
+store--e.g., if FS is the root file system."
(or (%file-system-needed-for-boot? fs)
- (string=? "/" (file-system-mount-point fs))))
+ (and (file-prefix? (file-system-mount-point fs) (%store-prefix))
+ (not (memq 'bind-mount (file-system-flags fs))))))
+
+(define (file-system->spec fs)
+ "Return a list corresponding to file-system FS that can be passed to the
+initrd code."
+ (match fs
+ (($ <file-system> device title mount-point type flags options _ _ check?)
+ (list (if (uuid? device)
+ `(uuid ,(uuid-type device) ,(uuid-bytevector device))
+ device)
+ title mount-point type flags options check?))))
+
+(define (spec->file-system sexp)
+ "Deserialize SEXP, a list, to the corresponding <file-system> object."
+ (match sexp
+ ((device title mount-point type flags options check?)
+ (file-system
+ (device (match device
+ (('uuid (? symbol? type) (? bytevector? bv))
+ (bytevector->uuid bv type))
+ (_
+ device)))
+ (title title)
+ (mount-point mount-point) (type type)
+ (flags flags) (options options)
+ (check? check?)))))
+
+(define (specification->file-system-mapping spec writable?)
+ "Read the SPEC and return the corresponding <file-system-mapping>. SPEC is
+a string of the form \"SOURCE\" or \"SOURCE=TARGET\". The former specifies
+that SOURCE from the host should be mounted at SOURCE in the other system.
+The latter format specifies that SOURCE from the host should be mounted at
+TARGET in the other system."
+ (let ((index (string-index spec #\=)))
+ (if index
+ (file-system-mapping
+ (source (substring spec 0 index))
+ (target (substring spec (+ 1 index)))
+ (writable? writable?))
+ (file-system-mapping
+ (source spec)
+ (target spec)
+ (writable? writable?)))))
+
+\f
+;;;
+;;; Common file systems.
+;;;
(define %fuse-control-file-system
;; Control file system for Linux' file systems in user-space (FUSE).
(type "binfmt_misc")
(check? #f)))
-(define %devtmpfs-file-system
- ;; /dev as a 'devtmpfs' file system, needed for udev.
- (file-system
- (device "none")
- (mount-point "/dev")
- (type "devtmpfs")
- (check? #f)
-
- ;; Mount it from the initrd so /dev/pts & co. can then be mounted over it.
- (needed-for-boot? #t)))
-
(define %tty-gid
;; ID of the 'tty' group. Allocate it statically to make it easy to refer
;; to it from here and from the 'tty' group definitions.
(options "size=50%") ;TODO: make size configurable
(create-mount-point? #t)))
+(define %immutable-store
+ ;; Read-only store to avoid users or daemons accidentally modifying it.
+ ;; 'guix-daemon' has provisions to remount it read-write in its own name
+ ;; space.
+ (file-system
+ (device (%store-prefix))
+ (mount-point (%store-prefix))
+ (type "none")
+ (check? #f)
+ (flags '(read-only bind-mount))))
+
+(define %control-groups
+ (let ((parent (file-system
+ (device "cgroup")
+ (mount-point "/sys/fs/cgroup")
+ (type "tmpfs")
+ (check? #f))))
+ (cons parent
+ (map (lambda (subsystem)
+ (file-system
+ (device "cgroup")
+ (mount-point (string-append "/sys/fs/cgroup/" subsystem))
+ (type "cgroup")
+ (check? #f)
+ (options subsystem)
+ (create-mount-point? #t)
+
+ ;; This must be mounted after, and unmounted before the
+ ;; parent directory.
+ (dependencies (list parent))))
+ '("cpuset" "cpu" "cpuacct" "memory" "devices" "freezer"
+ "blkio" "perf_event" "hugetlb")))))
+
+(define %elogind-file-systems
+ ;; We don't use systemd, but these file systems are needed for elogind,
+ ;; which was extracted from systemd.
+ (list (file-system
+ (device "none")
+ (mount-point "/run/systemd")
+ (type "tmpfs")
+ (check? #f)
+ (flags '(no-suid no-dev no-exec))
+ (options "mode=0755")
+ (create-mount-point? #t))
+ (file-system
+ (device "none")
+ (mount-point "/run/user")
+ (type "tmpfs")
+ (check? #f)
+ (flags '(no-suid no-dev no-exec))
+ (options "mode=0755")
+ (create-mount-point? #t))
+ ;; Elogind uses cgroups to organize processes, allowing it to map PIDs
+ ;; to sessions. Elogind's cgroup hierarchy isn't associated with any
+ ;; resource controller ("subsystem").
+ (file-system
+ (device "cgroup")
+ (mount-point "/sys/fs/cgroup/elogind")
+ (type "cgroup")
+ (check? #f)
+ (options "none,name=elogind")
+ (create-mount-point? #t)
+ (dependencies (list (car %control-groups))))))
+
(define %base-file-systems
;; List of basic file systems to be mounted. Note that /proc and /sys are
;; currently mounted by the initrd.
- (list %devtmpfs-file-system
- %pseudo-terminal-file-system
- %shared-memory-file-system))
+ (append (list %pseudo-terminal-file-system
+ %shared-memory-file-system
+ %immutable-store)
+ %control-groups))
+;; File systems for Linux containers differ from %base-file-systems in that
+;; they impose additional restrictions such as no-exec or need different
+;; options to function properly.
+;;
+;; The file system flags and options conform to the libcontainer
+;; specification:
+;; https://github.com/docker/libcontainer/blob/master/SPEC.md#filesystem
+(define %container-file-systems
+ (list
+ ;; Pseudo-terminal file system.
+ (file-system
+ (device "none")
+ (mount-point "/dev/pts")
+ (type "devpts")
+ (flags '(no-exec no-suid))
+ (needed-for-boot? #t)
+ (create-mount-point? #t)
+ (check? #f)
+ (options "newinstance,ptmxmode=0666,mode=620"))
+ ;; Shared memory file system.
+ (file-system
+ (device "tmpfs")
+ (mount-point "/dev/shm")
+ (type "tmpfs")
+ (flags '(no-exec no-suid no-dev))
+ (options "mode=1777,size=65536k")
+ (needed-for-boot? #t)
+ (create-mount-point? #t)
+ (check? #f))
+ ;; Message queue file system.
+ (file-system
+ (device "mqueue")
+ (mount-point "/dev/mqueue")
+ (type "mqueue")
+ (flags '(no-exec no-suid no-dev))
+ (needed-for-boot? #t)
+ (create-mount-point? #t)
+ (check? #f))))
\f
;;;
-;;; Mapped devices, for Linux's device-mapper.
+;;; Shared file systems, for VMs/containers.
;;;
-(define-record-type* <mapped-device> mapped-device
- make-mapped-device
- mapped-device?
- (source mapped-device-source) ;string
- (target mapped-device-target) ;string
- (type mapped-device-type)) ;<mapped-device-kind>
-
-(define-record-type* <mapped-device-type> mapped-device-kind
- make-mapped-device-kind
- mapped-device-kind?
- (open mapped-device-kind-open) ;source target -> gexp
- (close mapped-device-kind-close ;source target -> gexp
- (default (const #~(const #f)))))
+;; Mapping of host file system SOURCE to mount point TARGET in the guest.
+(define-record-type* <file-system-mapping> file-system-mapping
+ make-file-system-mapping
+ file-system-mapping?
+ (source file-system-mapping-source) ;string
+ (target file-system-mapping-target) ;string
+ (writable? file-system-mapping-writable? ;Boolean
+ (default #f)))
+
+(define (file-system-mapping->bind-mount mapping)
+ "Return a file system that realizes MAPPING, a <file-system-mapping>, using
+a bind mount."
+ (match mapping
+ (($ <file-system-mapping> source target writable?)
+ (file-system
+ (mount-point target)
+ (device source)
+ (type "none")
+ (flags (if writable?
+ '(bind-mount)
+ '(bind-mount read-only)))
+ (check? #f)
+ (create-mount-point? #t)))))
+
+(define %store-mapping
+ ;; Mapping of the host's store into the guest.
+ (file-system-mapping
+ (source (%store-prefix))
+ (target (%store-prefix))
+ (writable? #f)))
+
+(define %network-configuration-files
+ ;; List of essential network configuration files.
+ '("/etc/resolv.conf"
+ "/etc/nsswitch.conf"
+ "/etc/services"
+ "/etc/hosts"))
+
+(define %network-file-mappings
+ ;; List of file mappings for essential network files.
+ (filter-map (lambda (file)
+ (file-system-mapping
+ (source file)
+ (target file)
+ ;; XXX: On some GNU/Linux systems, /etc/resolv.conf is a
+ ;; symlink to a file in a tmpfs which, for an unknown reason,
+ ;; cannot be bind mounted read-only within the container.
+ (writable? (string=? file "/etc/resolv.conf"))))
+ %network-configuration-files))
+
+(define (file-system-type-predicate type)
+ "Return a predicate that, when passed a file system, returns #t if that file
+system has the given TYPE."
+ (lambda (fs)
+ (string=? (file-system-type fs) type)))
;;; file-systems.scm ends here
HCoop / jackhill / guix / guix.git / blobdiff