me
/
guix
Archived
1
0
Fork 0
Code

file-system: Add mount-may-fail? option. 

* gnu/system/file-systems.scm (<file-system>): Add a mount-may-fail? field.
(file-system->spec): adapt accordingly,
(spec->file-system): ditto.
* gnu/build/file-systems.scm (mount-file-system): If 'system-error is raised
and mount-may-fail? is true, ignore it. Otherwise, re-raise the exception.

Signed-off-by: Mathieu Othacehe <othacehe@gnu.org>
master
Mathieu Othacehe 2020-07-31 13:43:20 +02:00
parent 6bb07e91e1
commit 7c27bd115b
No known key found for this signature in database
GPG Key ID: 8354763531769CA6
2 changed files with 34 additions and 22 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

45
gnu/build/file-systems.scm
View File

@ -814,26 +814,33 @@ corresponds to the symbols listed in FLAGS."
(when (file-system-check? fs) (when (file-system-check? fs)
(check-file-system source type)) (check-file-system source type))
;; Create the mount point. Most of the time this is a directory, but (catch 'system-error
;; in the case of a bind mount, a regular file or socket may be needed. (lambda ()
(if (and (= MS_BIND (logand flags MS_BIND)) ;; Create the mount point. Most of the time this is a directory, but
(not (file-is-directory? source))) ;; in the case of a bind mount, a regular file or socket may be
(unless (file-exists? mount-point) ;; needed.
(mkdir-p (dirname mount-point)) (if (and (= MS_BIND (logand flags MS_BIND))
(call-with-output-file mount-point (const #t))) (not (file-is-directory? source)))
(mkdir-p mount-point)) (unless (file-exists? mount-point)
(mkdir-p (dirname mount-point))
(call-with-output-file mount-point (const #t)))
(mkdir-p mount-point))
(cond (cond
((string-prefix? "nfs" type) ((string-prefix? "nfs" type)
(mount-nfs source mount-point type flags options)) (mount-nfs source mount-point type flags options))
(else (else
(mount source mount-point type flags options))) (mount source mount-point type flags options)))
;; For read-only bind mounts, an extra remount is needed, as per ;; For read-only bind mounts, an extra remount is needed, as per
;; <http://lwn.net/Articles/281157/>, which still applies to Linux 4.0. ;; <http://lwn.net/Articles/281157/>, which still applies to Linux
(when (and (= MS_BIND (logand flags MS_BIND)) ;; 4.0.
(= MS_RDONLY (logand flags MS_RDONLY))) (when (and (= MS_BIND (logand flags MS_BIND))
(let ((flags (logior MS_BIND MS_REMOUNT MS_RDONLY))) (= MS_RDONLY (logand flags MS_RDONLY)))
(mount source mount-point type flags #f))))) (let ((flags (logior MS_BIND MS_REMOUNT MS_RDONLY)))
(mount source mount-point type flags #f))))
(lambda args
(or (file-system-mount-may-fail? fs)
(apply throw args))))))
;;; file-systems.scm ends here ;;; file-systems.scm ends here

11
gnu/system/file-systems.scm
View File

@ -48,6 +48,7 @@
alist->file-system-options alist->file-system-options
file-system-mount? file-system-mount?
file-system-mount-may-fail?
file-system-check? file-system-check?
file-system-create-mount-point? file-system-create-mount-point?
file-system-dependencies file-system-dependencies
@ -114,6 +115,8 @@
(default #f)) (default #f))
(mount? file-system-mount? ; Boolean (mount? file-system-mount? ; Boolean
(default #t)) (default #t))
(mount-may-fail? file-system-mount-may-fail? ; Boolean
(default #f))
(needed-for-boot? %file-system-needed-for-boot? ; Boolean (needed-for-boot? %file-system-needed-for-boot? ; Boolean
(default #f)) (default #f))
(check? file-system-check? ; Boolean (check? file-system-check? ; Boolean
@ -301,18 +304,19 @@ store--e.g., if FS is the root file system."
"Return a list corresponding to file-system FS that can be passed to the "Return a list corresponding to file-system FS that can be passed to the
initrd code." initrd code."
(match fs (match fs
(($ <file-system> device mount-point type flags options _ _ check?) (($ <file-system> device mount-point type flags options mount?
mount-may-fail? needed-for-boot? check?)
(list (cond ((uuid? device) (list (cond ((uuid? device)
`(uuid ,(uuid-type device) ,(uuid-bytevector device))) `(uuid ,(uuid-type device) ,(uuid-bytevector device)))
((file-system-label? device) ((file-system-label? device)
`(file-system-label ,(file-system-label->string device))) `(file-system-label ,(file-system-label->string device)))
(else device)) (else device))
mount-point type flags options check?)))) mount-point type flags options mount-may-fail? check?))))
(define (spec->file-system sexp) (define (spec->file-system sexp)
"Deserialize SEXP, a list, to the corresponding <file-system> object." "Deserialize SEXP, a list, to the corresponding <file-system> object."
(match sexp (match sexp
((device mount-point type flags options check?) ((device mount-point type flags options mount-may-fail? check?)
(file-system (file-system
(device (match device (device (match device
(('uuid (? symbol? type) (? bytevector? bv)) (('uuid (? symbol? type) (? bytevector? bv))
@ -323,6 +327,7 @@ initrd code."
device))) device)))
(mount-point mount-point) (type type) (mount-point mount-point) (type type)
(flags flags) (options options) (flags flags) (options options)
(mount-may-fail? mount-may-fail?)
(check? check?))))) (check? check?)))))
(define (specification->file-system-mapping spec writable?) (define (specification->file-system-mapping spec writable?)