aboutsummaryrefslogtreecommitdiff
path: root/gnu/build/file-systems.scm
diff options
context:
space:
mode:
Diffstat (limited to 'gnu/build/file-systems.scm')
-rw-r--r--gnu/build/file-systems.scm103
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))