;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
#:use-module (ice-9 match)
#:use-module (rnrs bytevectors)
#:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-9)
+ #:use-module (srfi srfi-9 gnu)
#:use-module (guix records)
#:use-module (gnu system uuid)
#:re-export (uuid ;backward compatibility
string->uuid
uuid->string)
- #:export (<file-system>
- file-system
+ #:export (file-system
file-system?
file-system-device
- file-system-title
+ file-system-title ;deprecated
file-system-mount-point
file-system-type
file-system-needed-for-boot?
file-system-type-predicate
+ file-system-label
+ file-system-label?
+ file-system-label->string
+
file-system->spec
spec->file-system
specification->file-system-mapping
+ %pseudo-file-system-types
%fuse-control-file-system
%binary-format-file-system
%shared-memory-file-system
;;; Code:
;; File system declaration.
-(define-record-type* <file-system> file-system
+(define-record-type* <file-system> %file-system
make-file-system
file-system?
- (device file-system-device) ; string
- (title file-system-title ; 'device | 'label | 'uuid
- (default 'device))
+ (device file-system-device) ; string | <uuid> | <file-system-label>
(mount-point file-system-mount-point) ; string
(type file-system-type) ; string
(flags file-system-flags ; list of symbols
(default (current-source-location))
(innate)))
+;; A file system label for use in the 'device' field.
+(define-record-type <file-system-label>
+ (file-system-label label)
+ file-system-label?
+ (label file-system-label->string))
+
+(set-record-type-printer! <file-system-label>
+ (lambda (obj port)
+ (format port "#<file-system-label ~s>"
+ (file-system-label->string obj))))
+
+(define-syntax report-deprecation
+ (lambda (s)
+ "Report the use of the now-deprecated 'title' field."
+ (syntax-case s ()
+ ((_ field)
+ (let* ((source (syntax-source #'field))
+ (file (and source (assq-ref source 'filename)))
+ (line (and source
+ (and=> (assq-ref source 'line) 1+)))
+ (column (and source (assq-ref source 'column))))
+ (format (current-error-port)
+ "~a:~a:~a: warning: 'title' field is deprecated~%"
+ file line column)
+ #t)))))
+
+;; Helper for 'process-file-system-declaration'.
+(define-syntax device-expression
+ (syntax-rules (quote label uuid device)
+ ((_ (quote label) dev)
+ (file-system-label dev))
+ ((_ (quote uuid) dev)
+ (if (uuid? dev) dev (uuid dev)))
+ ((_ (quote device) dev)
+ dev)
+ ((_ title dev)
+ (case title
+ ((label) (file-system-label dev))
+ ((uuid) (uuid dev))
+ (else dev)))))
+
+;; Helper to interpret the now-deprecated 'title' field. Detect forms like
+;; (title 'label), remove them, and adjust the 'device' field accordingly.
+;; TODO: Remove this once 'title' has been deprecated long enough.
+(define-syntax process-file-system-declaration
+ (syntax-rules (device title)
+ ((_ () (rest ...) #f #f) ;no 'title' and no 'device' field
+ (%file-system rest ...))
+ ((_ () (rest ...) dev #f) ;no 'title' field
+ (%file-system rest ... (device dev)))
+ ((_ () (rest ...) dev titl) ;got a 'title' field
+ (%file-system rest ...
+ (device (device-expression titl dev))))
+ ((_ ((title titl) rest ...) (previous ...) dev _)
+ (begin
+ (report-deprecation (title titl))
+ (process-file-system-declaration (rest ...)
+ (previous ...)
+ dev titl)))
+ ((_ ((device dev) rest ...) (previous ...) _ titl)
+ (process-file-system-declaration (rest ...)
+ (previous ...)
+ dev titl))
+ ((_ (field rest ...) (previous ...) dev titl)
+ (process-file-system-declaration (rest ...)
+ (previous ... field)
+ dev titl))))
+
+(define-syntax-rule (file-system fields ...)
+ (process-file-system-declaration (fields ...) () #f #f))
+
+(define (file-system-title fs) ;deprecated
+ (match (file-system-device fs)
+ ((? file-system-label?) 'label)
+ ((? uuid?) 'uuid)
+ ((? string?) 'device)))
+
;; 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)
+ ;; Note: If we have (guix store database) in the search path and we do *not*
+ ;; have (guix store) proper, 'resolve-module' returns an empty (guix store)
+ ;; with one sub-module.
+ (cond ((and=> (resolve-module '(guix store) #:ensure #f)
+ (lambda (store)
+ (module-variable store '%store-prefix)))
=>
- (lambda (store)
- ((module-ref store '%store-prefix))))
+ (lambda (variable)
+ ((variable-ref variable))))
((getenv "NIX_STORE")
=> identity)
(else
"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?))))
+ (($ <file-system> device mount-point type flags options _ _ check?)
+ (list (cond ((uuid? device)
+ `(uuid ,(uuid-type device) ,(uuid-bytevector device)))
+ ((file-system-label? device)
+ `(file-system-label ,(file-system-label->string device)))
+ (else device))
+ 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?)
+ ((device mount-point type flags options check?)
(file-system
(device (match device
(('uuid (? symbol? type) (? bytevector? bv))
(bytevector->uuid bv type))
+ (('file-system-label (? string? label))
+ (file-system-label label))
(_
device)))
- (title title)
(mount-point mount-point) (type type)
(flags flags) (options options)
(check? check?)))))
;;; Common file systems.
;;;
+(define %pseudo-file-system-types
+ ;; List of know pseudo file system types. This is used when validating file
+ ;; system definitions.
+ '("binfmt_misc" "cgroup" "debugfs" "devpts" "devtmpfs" "efivarfs" "fusectl"
+ "hugetlbfs" "overlay" "proc" "securityfs" "sysfs" "tmpfs"))
+
(define %fuse-control-file-system
;; Control file system for Linux' file systems in user-space (FUSE).
(file-system
;; parent directory.
(dependencies (list parent))))
'("cpuset" "cpu" "cpuacct" "memory" "devices" "freezer"
- "blkio" "perf_event" "hugetlb")))))
+ "blkio" "perf_event")))))
(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))))))
+ (append
+ (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)))))
+ %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.
- (append (list %pseudo-terminal-file-system
- %shared-memory-file-system
- %immutable-store)
- %control-groups))
+ (list %pseudo-terminal-file-system
+ %shared-memory-file-system
+ %immutable-store))
;; File systems for Linux containers differ from %base-file-systems in that
;; they impose additional restrictions such as no-exec or need different
HCoop / jackhill / guix / guix.git / blobdiff