[bug#70542] [PATCH v2 3/3] file-systems: Add support for mounting CIFS file systems

[Richard Sent <richard@freakingpenguin.com>]

* 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 <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,7 @@ (define-module (gnu build file-systems)
   #: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 @@ (define (canonicalize-device-spec spec)
 
   (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 @@ (define* (mount-file-system fs #:key (root "/root")
                                 (string-append "," options)
                                 "")))))
 
+  (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))
+           ;; 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 @@ (define* (mount-file-system fs #:key (root "/root")
         (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 @@ (define (machine-check-file-system-availability 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 @@ (define (check-file-system-availability file-systems)
                    (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))
 
-- 
2.41.0