ryan77627/guix
1
0
Fork 0
mirror of https://git.in.rschanz.org/ryan77627/guix.git synced 2024-11-07 07:26:13 -05:00
Code Issues Projects Releases Packages Wiki Activity Actions

file-systems: Add support for mounting CIFS file systems

Browse source 
* 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
Signed-off-by: Ludovic Courtès <ludo@gnu.org>
This commit is contained in:
Richard Sent 2024-06-01 19:26:18 -04:00 committed by Ludovic Courtès
parent 9d6c4f5160
commit 3e87b207ce
No known key found for this signature in database
GPG key ID: 090B11993D9AEBB5
3 changed files with 47 additions and 4 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

45
gnu/build/file-systems.scm
View file

@ -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 (resolve find-partition spec fmt)
(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-nfs source mount-point type flags 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 "/"
@ -1215,6 +1254,8 @@ (define (mount-nfs source mount-point type flags options)
(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))

3
gnu/machine/ssh.scm
View file

@ -222,7 +222,8 @@ (define 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)))))
(operating-system-file-systems (machine-operating-system machine))))

3
guix/scripts/system.scm
View file

@ -591,7 +591,8 @@ (define relevant
(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))