diff options
Diffstat (limited to 'gnu/build/file-systems.scm')
-rw-r--r-- | gnu/build/file-systems.scm | 103 |
1 files changed, 96 insertions, 7 deletions
diff --git a/gnu/build/file-systems.scm b/gnu/build/file-systems.scm index 78d779f398..9ceb2fda4e 100644 --- a/gnu/build/file-systems.scm +++ b/gnu/build/file-systems.scm @@ -8,6 +8,7 @@ ;;; Copyright © 2020 Maxim Cournoyer <maxim.cournoyer@gmail.com> ;;; Copyright © 2022 Oleg Pykhalov <go.wigust@gmail.com> ;;; Copyright © 2024 Nicolas Graves <ngraves@ngraves.fr> +;;; Copyright © 2024 Richard Sent <richard@freakingpenguin.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -37,6 +38,8 @@ #:use-module (rnrs bytevectors) #:use-module (ice-9 match) #:use-module (ice-9 rdelim) + #:use-module (ice-9 regex) + #:use-module (ice-9 string-fun) #:use-module (system foreign) #:autoload (system repl repl) (start-repl) #:use-module (srfi srfi-1) @@ -1047,8 +1050,11 @@ file name or an nfs-root containing ':/')." (match spec ((? string?) - (if (or (string-contains spec ":/") (string=? spec "none")) - spec ; do not resolve NFS / tmpfs devices + (if (or (string-contains spec ":/") ;nfs + (and (>= (string-length spec) 2) + (equal? (string-take spec 2) "//")) ;cifs + (string=? spec "none")) + spec ; do not resolve NFS / CIFS / tmpfs devices ;; Nothing to do, but wait until SPEC shows up. (resolve identity spec identity))) ((? file-system-label?) @@ -1078,6 +1084,7 @@ an exception in such cases but perform the nearest sane action." ((string-prefix? "f2fs" type) check-f2fs-file-system) ((string-prefix? "ntfs" type) check-ntfs-file-system) ((string-prefix? "nfs" type) (const 'pass)) + ((string-prefix? "cifs" type) (const 'pass)) ((string-prefix? "xfs" type) check-xfs-file-system) (else #f))) @@ -1156,6 +1163,14 @@ corresponds to the symbols listed in FLAGS." (repair (file-system-repair fs))) "Mount the file system described by FS, a <file-system> object, under ROOT." + (define* (host-to-ip host #:optional service) + "Return the IP address for host, which may be an IP address or a hostname." + (let* ((aa (match (getaddrinfo host service) ((x . _) x))) + (sa (addrinfo:addr aa)) + (inet-addr (inet-ntop (sockaddr:fam sa) + (sockaddr:addr sa)))) + inet-addr)) + (define (mount-nfs source mount-point type flags options) (let* ((idx (string-rindex source #\:)) (host-part (string-take source idx)) @@ -1163,11 +1178,7 @@ corresponds to the symbols listed in FLAGS." (host (match (string-split host-part (string->char-set "[]")) (("" h "") h) ((h) h))) - (aa (match (getaddrinfo host "nfs") ((x . _) x))) - (sa (addrinfo:addr aa)) - (inet-addr (inet-ntop (sockaddr:fam sa) - (sockaddr:addr sa)))) - + (inet-addr (host-to-ip host "nfs"))) ;; Mounting an NFS file system requires passing the address ;; of the server in the addr= option (mount source mount-point type flags @@ -1176,6 +1187,82 @@ corresponds to the symbols listed in FLAGS." (if options (string-append "," options) ""))))) + + (define (read-cifs-credential-file file) + ;; Read password, user and domain options from file + ;; + ;; XXX: As of version 7.0, mount.cifs strips all lines of leading + ;; whitespace, parses those starting with "pass", "user" and "dom" into + ;; "pass=", "user=" and "domain=" options respectively and ignores + ;; everything else. To simplify the implementation, we pass those lines + ;; as is. As a consequence, the "password2" option can be specified in a + ;; credential file with the expected semantics (see: + ;; https://issues.guix.gnu.org/71594#3). + (with-input-from-file file + (lambda () + (let loop + ((next-line (read-line)) + (lines '())) + (match next-line + ((? eof-object?) + lines) + ((= string-trim line) + (loop (read-line) + (cond + ((string-prefix? "pass" line) + ;; mount.cifs escapes commas in the password by doubling + ;; them + (cons (string-replace-substring line "," ",,") + lines)) + ((or (string-prefix? "user" line) + (string-prefix? "dom" line)) + (cons line lines)) + ;; Ignore all other lines. + (else + lines))))))))) + + (define (mount-cifs source mount-point type flags options) + ;; Source is of form "//<server-ip-or-host>/<service>" + (let* ((regex-match (string-match "//([^/]+)/(.+)" source)) + (server (match:substring regex-match 1)) + (share (match:substring regex-match 2)) + ;; Match ",guest,", ",guest$", "^guest,", or "^guest$," not + ;; e.g. user=foo,pass=notaguest + (guest? (string-match "(^|,)(guest)($|,)" options)) + (credential-file (and=> (string-match "(^|,)(credentials|cred)=([^,]+)(,|$)" + options) + (cut match:substring <> 3))) + ;; Perform DNS resolution now instead of attempting kernel dns + ;; resolver upcalling. /sbin/request-key does not exist and the + ;; kernel hardcodes the path. + ;; + ;; (getaddrinfo) doesn't support cifs service, so omit it. + (inet-addr (host-to-ip server))) + (mount source mount-point type flags + (string-append "ip=" + inet-addr + ;; As of Linux af1a3d2ba9 (v5.11) unc is ignored + ;; and source is parsed by the kernel + ;; directly. Pass it for compatibility. + ",unc=" + ;; Match format of mount.cifs's mount syscall. + "\\\\" server "\\" share + (if guest? + ",user=,pass=" + "") + (if options + ;; No need to delete "guest" from options. + ;; linux/fs/smb/client/fs_context.c explicitly + ;; ignores it. Also, avoiding excess commas + ;; when deleting is a pain. + (string-append "," options) + "") + (if credential-file + ;; The "credentials" option is ignored too. + (string-join (read-cifs-credential-file credential-file) + "," 'prefix) + ""))))) + (let* ((type (file-system-type fs)) (source (canonicalize-device-spec (file-system-device fs))) (target (string-append root "/" @@ -1210,6 +1297,8 @@ corresponds to the symbols listed in FLAGS." (cond ((string-prefix? "nfs" type) (mount-nfs source target type flags options)) + ((string-prefix? "cifs" type) + (mount-cifs source target type flags options)) ((memq 'shared (file-system-flags fs)) (mount source target type flags options) (mount "none" target #f MS_SHARED)) |