From 892673762326a63b3aa29b5051159a5eb8df5151 Mon Sep 17 00:00:00 2001 From: Richard Sent Date: Thu, 25 Apr 2024 00:56:05 -0400 Subject: file-systems: Add support for mounting CIFS file systems * gnu/build/file-systems (canonicalize-device-name): Do not attempt to resolve CIFS formatted device specifications. (mount-file-systems): Add mount-cifs nested function. * gnu/machine/ssh.scm (machine-check-file-system-availability): Skip checking for CIFS availability, similar to NFS. * guix/scripts/system.scm (check-file-system-availability): Likewise. Change-Id: I182e290eba64bbe5d1332815eb93bb68c01e0c3c --- gnu/build/file-systems.scm | 45 +++++++++++++++++++++++++++++++++++++++++++-- gnu/machine/ssh.scm | 3 ++- guix/scripts/system.scm | 3 ++- 3 files changed, 47 insertions(+), 4 deletions(-) diff --git a/gnu/build/file-systems.scm b/gnu/build/file-systems.scm index e47ac39ab0..ae29b36c4e 100644 --- a/gnu/build/file-systems.scm +++ b/gnu/build/file-systems.scm @@ -8,6 +8,7 @@ ;;; Copyright © 2020 Maxim Cournoyer ;;; Copyright © 2022 Oleg Pykhalov ;;; Copyright © 2024 Nicolas Graves +;;; Copyright © 2024 Richard Sent ;;; ;;; This file is part of GNU Guix. ;;; @@ -37,6 +38,7 @@ #:use-module (rnrs bytevectors) #:use-module (ice-9 match) #:use-module (ice-9 rdelim) + #:use-module (ice-9 regex) #:use-module (system foreign) #:autoload (system repl repl) (start-repl) #:use-module (srfi srfi-1) @@ -1047,8 +1049,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?) @@ -1181,6 +1186,40 @@ corresponds to the symbols listed in FLAGS." (string-append "," options) ""))))) + (define (mount-cifs source mount-point type flags options) + ;; Source is of form "///" + (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)) + ;; 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) + ""))))) + (let* ((type (file-system-type fs)) (source (canonicalize-device-spec (file-system-device fs))) (target (string-append root "/" @@ -1215,6 +1254,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)) diff --git a/gnu/machine/ssh.scm b/gnu/machine/ssh.scm index b47ce7c225..0be9ebbc0d 100644 --- a/gnu/machine/ssh.scm +++ b/gnu/machine/ssh.scm @@ -222,7 +222,8 @@ exist on the machine." (not (member (file-system-type fs) %pseudo-file-system-types)) ;; Don't try to validate network file systems. - (not (string-prefix? "nfs" (file-system-type fs))) + (not (or (string-prefix? "nfs" (file-system-type fs)) + (string-prefix? "cifs" (file-system-type fs)))) (not (memq 'bind-mount (file-system-flags fs))))) (operating-system-file-systems (machine-operating-system machine)))) diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index 2260bcf985..99c58f3812 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -591,7 +591,8 @@ any, are available. Raise an error if they're not." (not (member (file-system-type fs) %pseudo-file-system-types)) ;; Don't try to validate network file systems. - (not (string-prefix? "nfs" (file-system-type fs))) + (not (or (string-prefix? "nfs" (file-system-type fs)) + (string-prefix? "cifs" (file-system-type fs)))) (not (memq 'bind-mount (file-system-flags fs))))) file-systems)) -- cgit v1.2.3