[bug#70542] [PATCH 3/4] 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.
* gnu/build/file-systems (mount-file-system): Add (mount-cifs)
and (host-to-ip). Logic for ip/host to ip resolution was duplicated with
mount-nfs, so isolate into a dedicated function.

Change-Id: I522d70a10651ca79533a4fc60b96b884243a3526
---
 gnu/build/file-systems.scm | 60 +++++++++++++++++++++++++++++++++-----
 1 file changed, 53 insertions(+), 7 deletions(-)

diff --git a/gnu/build/file-systems.scm b/gnu/build/file-systems.scm
index 78d779f398..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?)
@@ -1156,6 +1161,14 @@ (define* (mount-file-system fs #:key (root "/root")
                             (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 +1176,7 @@ (define* (mount-file-system fs #:key (root "/root")
            (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 +1185,41 @@ (define* (mount-file-system fs #:key (root "/root")
                             (if options
                                 (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 "/"
@@ -1210,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))
-- 
2.41.0