diff --git a/gnu/build/file-systems.scm b/gnu/build/file-systems.scm index ddf6117b67..4ecb58c8ea 100644 --- a/gnu/build/file-systems.scm +++ b/gnu/build/file-systems.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2020 Ludovic Courtès +;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2020, 2021 Ludovic Courtès ;;; Copyright © 2016, 2017 David Craven ;;; Copyright © 2017 Mathieu Othacehe ;;; Copyright © 2019 Guillaume Le Vaillant @@ -36,6 +36,7 @@ #:use-module (system foreign) #:autoload (system repl repl) (start-repl) #:use-module (srfi srfi-1) + #:use-module (srfi srfi-9) #:use-module (srfi srfi-26) #:export (disk-partitions partition-label-predicate @@ -886,6 +887,59 @@ corresponds to the symbols listed in FLAGS." (() 0)))) +(define-record-type + (%mount source point devno type options) + mount? + (devno mount-device-number) ;st_dev + (source mount-source) + (point mount-point) + (type mount-type) + (options mount-options)) + +(define (octal-decode str) + "Decode octal escapes from STR and return the corresponding string. STR may +look like this: \"white\\040space\", which is decoded as \"white space\"." + (define char-set:octal + (char-set #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7)) + (define (octal? c) + (char-set-contains? char-set:octal c)) + + (let loop ((chars (string->list str)) + (result '())) + (match chars + (() + (list->string (reverse result))) + ((#\\ (? octal? a) (? octal? b) (? octal? c) . rest) + (loop rest + (cons (integer->char + (string->number (list->string (list a b c)) 8)) + result))) + ((head . tail) + (loop tail (cons head result)))))) + +(define (string->device-number str) + (match (string-split str #\:) + (((= string->number major) (= string->number minor)) + (+ (* major 256) minor)))) + +(define (mounts) + "Return the list of mounts ( records) visible in the namespace of the +current process." + (call-with-input-file "/proc/self/mountinfo" + (lambda (port) + (let loop ((result '())) + (let ((line (read-line port))) + (if (eof-object? line) + (reverse result) + (match (string-tokenize line) + ((id parent-id major:minor root mount-point + options _ _ type source _ ...) + (let ((devno (string->device-number major:minor))) + (loop (cons (%mount (octal-decode source) + (octal-decode mount-point) + devno type options) + result))))))))))) + (define* (mount-file-system fs #:key (root "/root")) "Mount the file system described by FS, a object, under ROOT." @@ -894,8 +948,8 @@ corresponds to the symbols listed in FLAGS." (host-part (string-take source idx)) ;; Strip [] from around host if present (host (match (string-split host-part (string->char-set "[]")) - (("" h "") h) - ((h) h))) + (("" h "") h) + ((h) h))) (aa (match (getaddrinfo host "nfs") ((x . _) x))) (sa (addrinfo:addr aa)) (inet-addr (inet-ntop (sockaddr:fam sa) @@ -912,7 +966,7 @@ corresponds to the symbols listed in FLAGS." (let ((type (file-system-type fs)) (options (file-system-options fs)) (source (canonicalize-device-spec (file-system-device fs))) - (mount-point (string-append root "/" + (target (string-append root "/" (file-system-mount-point fs))) (flags (mount-flags->bit-mask (file-system-flags fs)))) (when (file-system-check? fs) @@ -925,24 +979,30 @@ corresponds to the symbols listed in FLAGS." ;; needed. (if (and (= MS_BIND (logand flags MS_BIND)) (not (file-is-directory? source))) - (unless (file-exists? mount-point) - (mkdir-p (dirname mount-point)) - (call-with-output-file mount-point (const #t))) - (mkdir-p mount-point)) + (unless (file-exists? target) + (mkdir-p (dirname target)) + (call-with-output-file target (const #t))) + (mkdir-p target)) (cond ((string-prefix? "nfs" type) - (mount-nfs source mount-point type flags options)) + (mount-nfs source target type flags options)) (else - (mount source mount-point type flags options))) + (mount source target type flags options))) ;; For read-only bind mounts, an extra remount is needed, as per ;; , which still applies to Linux ;; 4.0. (when (and (= MS_BIND (logand flags MS_BIND)) (= MS_RDONLY (logand flags MS_RDONLY))) - (let ((flags (logior MS_BIND MS_REMOUNT MS_RDONLY))) - (mount source mount-point type flags #f)))) + (let ((flags (logior MS_BIND MS_REMOUNT MS_RDONLY)) + (options (and=> (find (let ((devno (stat:dev (lstat source)))) + (lambda (mount) + (= (mount-device-number mount) + devno))) + (mounts)) + mount-options))) + (mount source target type flags options)))) (lambda args (or (file-system-mount-may-fail? fs) (apply throw args))))))