emacs/gnu.emacs
1
0
Fork 0
mirror of https://git.savannah.gnu.org/git/emacs.git synced 2026-09-10 15:56:35 -04:00
Code Issues Actions Packages Projects Releases Wiki Activity

Backport: Restrict Tramp user name

Browse source 
* doc/misc/tramp.texi (File name syntax): The user name can also
be an environment variable.

* lisp/net/tramp.el (tramp-build-prefix-regexp):
* lisp/net/tramp-gvfs.el (tramp-gvfs-handle-expand-file-name)
(tramp-gvfs-get-file-attributes, tramp-gvfs-file-name)
(tramp-gvfs-url-host, tramp-gvfs-handler-mounted-unmounted)
(tramp-gvfs-connection-mounted-p, tramp-gvfs-mount-spec-entry)
(tramp-gvfs-mount-spec):
* lisp/net/tramp-rclone.el (tramp-rclone-parse-device-names)
(tramp-rclone-remote-file-name):
* lisp/net/tramp-smb.el (tramp-smb-get-share, tramp-smb-get-localname):
Use string-anchored regexp, not line-anchored.

* lisp/net/tramp.el (tramp-prefix-regexp): Adapt docstring.
(tramp-user-regexp): Exclude shell meta characters.
(tramp-dissect-file-name, tramp-file-name-handler):
Expand environment variable.
(tramp-convert-file-attributes):
* lisp/net/tramp-gvfs.el (tramp-gvfs-handle-file-attributes):
Quote symbolic link target with remote file name syntax.

* test/lisp/net/tramp-tests.el (tramp-test01-file-name-syntax)
(tramp-test01-file-name-syntax-simplified)
(tramp-test01-file-name-syntax-separate)
(tramp-test02-file-name-dissect)
(tramp-test02-file-name-dissect-simplified)
(tramp-test02-file-name-dissect-separate)
(tramp-test21-file-links): Extend test.

(cherry picked from commit f3e7104d05)
This commit is contained in:
Michael Albinus 2026-08-21 14:23:38 +02:00
parent 61700f9dd6
commit bd5cbf47da
6 changed files with 121 additions and 34 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

4
doc/misc/tramp.texi
View file

@ -3689,7 +3689,9 @@ brackets @file{@value{ipv6prefix}} and @file{@value{ipv6postfix}}.
By default, @value{tramp} will use the current local user name as the
remote user name for log in to the remote host. Specifying a
different name using the proper syntax will override this default
behavior: @file{@trampfn{method,user@@host,path/to/file}}.
behavior: @file{@trampfn{method,user@@host,path/to/file}}. The user
name can also be taken from an environment variable, like
@file{@trampfn{method,@env{$MY_REMOTE_USER}@@host,path/to/file}}.
@file{@trampfn{ssh,daniel@@melancholia,.emacs}} is for file
@file{.emacs} in @samp{daniel}'s home directory on the host,

36
lisp/net/tramp-gvfs.el
View file

@ -1246,7 +1246,7 @@ file names."
(when (string-match
(rx bos "/" (+ (not "/")) (group "/.." (? "/"))) localname)
(setq localname (replace-match "/" t t localname 1)))
(when (string-match (rx bol "/.." (? "/")) localname)
(when (string-match (rx bos "/.." (? "/")) localname)
(setq localname (replace-match "/" t t localname))))
;; There might be a double slash. Remove this.
(while (string-match "//" localname)
@ -1340,8 +1340,8 @@ If FILE-SYSTEM is non-nil, return file system attributes."
(with-parsed-tramp-file-name filename nil
(setq localname (file-name-unquote localname))
(if (or (and (string-match-p
(rx bol (| "afp" (: "dav" (? "s")) "smb") eol) method)
(string-match-p (rx bol (? "/") (+ (not "/")) eol) localname))
(rx bos (| "afp" (: "dav" (? "s")) "smb") eos) method)
(string-match-p (rx bos (? "/") (+ (not "/")) eos) localname))
(string-equal localname "/"))
(tramp-gvfs-get-root-attributes filename)
(assoc
@ -1375,7 +1375,11 @@ If FILE-SYSTEM is non-nil, return file system attributes."
(lambda (x)
(unibyte-string (string-to-number (match-string 1 x) 16)))
res-symlink-target)
'utf-8)))
'utf-8))
;; If the resulting localname looks remote, we must quote it
;; for security reasons.
(when (tramp-tramp-file-p res-symlink-target)
(setq res-symlink-target (file-name-quote res-symlink-target 'top))))
;; ... number links
(setq res-numlinks
(string-to-number
@ -1768,14 +1772,14 @@ ID-FORMAT valid values are `string' and `integer'."
"Retrieve file name from D-Bus OBJECT-PATH."
(dbus-unescape-from-identifier
(replace-regexp-in-string
(rx bol (* nonl) "/" (group (+ (not "/"))) eol) "\\1" object-path)))
(rx bos (* nonl) "/" (group (+ (not "/"))) eos) "\\1" object-path)))
(defun tramp-gvfs-url-host (url)
"Return the host name part of URL, a string.
We cannot use `url-host', because `url-generic-parse-url' returns
a downcased host name only."
(and (stringp url)
(string-match (rx bol (+ alnum) "://" (group (+ (not (any "/:"))))) url)
(string-match (rx bos (+ alnum) "://" (group (+ (not (any "/:"))))) url)
(match-string 1 url)))
;; This is used in GNU ELPA package tramp-locproc.el.
@ -1929,7 +1933,7 @@ Their full names are \"org.gtk.vfs.MountTracker.mounted\" and
(cadr (assoc "ssl" (cadr mount-spec)))))
(uri (tramp-gvfs-dbus-byte-array-to-string
(cadr (assoc "uri" (cadr mount-spec))))))
(when (string-match (rx bol (group (| "afp" "smb"))) method)
(when (string-match (rx bos (group (| "afp" "smb"))) method)
(setq method (match-string 1 method)))
(when (and (string-equal "dav" method) (string-equal "true" ssl))
(setq method "davs"))
@ -2029,7 +2033,7 @@ Their full names are \"org.gtk.vfs.MountTracker.mounted\" and
(or
(cadr (assoc "share" (cadr mount-spec)))
(cadr (assoc "volume" (cadr mount-spec)))))))
(when (string-match (rx bol (group (| "afp" "smb"))) method)
(when (string-match (rx bos (group (| "afp" "smb"))) method)
(setq method (match-string 1 method)))
(when (and (string-equal "dav" method) (string-equal "true" ssl))
(setq method "davs"))
@ -2062,7 +2066,7 @@ Their full names are \"org.gtk.vfs.MountTracker.mounted\" and
(string-equal host (tramp-file-name-host vec))
(string-equal port (tramp-file-name-port vec))
(string-match-p
(rx bol "/" (literal (or share "")))
(rx bos "/" (literal (or share "")))
(tramp-file-name-unquote-localname vec)))
;; Set mountpoint and location.
(tramp-set-file-property vec "/" "fuse-mountpoint" fuse-mountpoint)
@ -2088,7 +2092,7 @@ Their full names are \"org.gtk.vfs.MountTracker.mounted\" and
(defun tramp-gvfs-mount-spec-entry (key value)
"Construct a mount-spec entry to be used in a mount_spec.
It was \"a(say)\", but has changed to \"a{sv})\"."
(if (string-match-p (rx bol "(aya{sv})") tramp-gvfs-mountlocation-signature)
(if (string-match-p (rx bos "(aya{sv})") tramp-gvfs-mountlocation-signature)
(list :dict-entry key
(list :variant (tramp-gvfs-dbus-string-to-byte-array value)))
(list :struct key (tramp-gvfs-dbus-string-to-byte-array value))))
@ -2107,9 +2111,9 @@ It was \"a(say)\", but has changed to \"a{sv})\"."
(tramp-media-device-port media) (tramp-file-name-port vec)))
(localname (tramp-file-name-unquote-localname vec))
(share (when (string-match
(rx bol (? "/") (group (+ (not "/")))) localname)
(rx bos (? "/") (group (+ (not "/")))) localname)
(match-string 1 localname)))
(ssl (if (string-match-p (rx bol (| "davs" "nextcloud")) method)
(ssl (if (string-match-p (rx bos (| "davs" "nextcloud")) method)
"true" "false"))
(mount-spec
`(:array
@ -2118,7 +2122,7 @@ It was \"a(say)\", but has changed to \"a{sv})\"."
(list (tramp-gvfs-mount-spec-entry "type" "smb-share")
(tramp-gvfs-mount-spec-entry "server" host)
(tramp-gvfs-mount-spec-entry "share" share)))
((string-match-p (rx bol (| "davs" "nextcloud")) method)
((string-match-p (rx bos (| "davs" "nextcloud")) method)
(list (tramp-gvfs-mount-spec-entry "type" "dav")
(tramp-gvfs-mount-spec-entry "host" host)
(tramp-gvfs-mount-spec-entry "ssl" ssl)))
@ -2132,7 +2136,7 @@ It was \"a(say)\", but has changed to \"a{sv})\"."
((string-equal "nextcloud" method)
(list (tramp-gvfs-mount-spec-entry "type" "owncloud")
(tramp-gvfs-mount-spec-entry "host" host)))
((string-match-p (rx bol "http") method)
((string-match-p (rx bos "http") method)
(list (tramp-gvfs-mount-spec-entry "type" "http")
(tramp-gvfs-mount-spec-entry
"uri"
@ -2149,8 +2153,8 @@ It was \"a(say)\", but has changed to \"a{sv})\"."
,@(when port
(list (tramp-gvfs-mount-spec-entry "port" port)))))
(mount-pref
(if (and (string-match-p (rx bol "dav") method)
(string-match (rx bol (? "/") (+ (not "/"))) localname))
(if (and (string-match-p (rx bos "dav") method)
(string-match (rx bos (? "/") (+ (not "/"))) localname))
(match-string 0 localname)
(tramp-gvfs-get-remote-prefix vec))))

4
lisp/net/tramp-rclone.el
View file

@ -192,7 +192,7 @@ arguments to pass to the OPERATION."
(with-tramp-connection-property nil "rclone-device-names"
(tramp-compat-seq-keep
(lambda (line)
(when (string-match (rx bol (group (+ (not blank))) ":" eol) line)
(when (string-match (rx bos (group (+ (not blank))) ":" eos) line)
`(nil ,(match-string 1 line))))
(tramp-process-lines nil tramp-rclone-program "listremotes"))))
@ -366,7 +366,7 @@ file names."
(tramp-rclone-maybe-open-connection v)
;; TODO: This shall be handled by `expand-file-name'.
(setq localname
(replace-regexp-in-string (rx bol ".") "" (or localname "")))
(replace-regexp-in-string (rx bos ".") "" (or localname "")))
(format "%s%s" (tramp-fuse-mounted-p v) localname)))
;; It is a local file name.
filename))

6
lisp/net/tramp-smb.el
View file

@ -1657,7 +1657,7 @@ VEC or USER, or if there is no home directory, return nil."
"Return the share name of LOCALNAME."
(save-match-data
(let ((localname (tramp-file-name-unquote-localname vec)))
(when (string-match (rx bol (? "/") (group (+ (not "/"))) "/") localname)
(when (string-match (rx bos (? "/") (group (+ (not "/"))) "/") localname)
(match-string 1 localname)))))
(defun tramp-smb-get-localname (vec &optional share)
@ -1670,7 +1670,7 @@ If VEC has no cifs capabilities, exchange \"/\" by \"\\\\\"."
(setq
localname
(if (string-match
(rx bol (? "/") (+ (not "/")) (group "/" (* nonl))) localname)
(rx bos (? "/") (+ (not "/")) (group "/" (* nonl))) localname)
;; There is a share, separated by "/".
(if (not (tramp-smb-get-cifs-capabilities vec))
(mapconcat
@ -1679,7 +1679,7 @@ If VEC has no cifs capabilities, exchange \"/\" by \"\\\\\"."
(match-string 1 localname))
;; There is just a share.
(if (string-match
(rx bol (? "/") (group (+ (not "/"))) eol) localname)
(rx bos (? "/") (group (+ (not "/"))) eos) localname)
(match-string 1 localname)
""))))

16
lisp/net/tramp.el
View file

@ -1024,11 +1024,11 @@ Used in `tramp-make-tramp-file-name'.")
(defun tramp-build-prefix-regexp ()
"Return `tramp-prefix-regexp'."
(rx bol (literal (tramp-build-prefix-format))))
(rx bos (literal (tramp-build-prefix-format))))
(defvar tramp-prefix-regexp nil ; Initialized when defining `tramp-syntax'!
"Regexp matching the very beginning of Tramp file names.
Should always start with \"^\". Derived from `tramp-prefix-format'.")
Should always start with \"\\\\=`\". Derived from `tramp-prefix-format'.")
(defconst tramp-method-regexp-alist
`((default . ,(rx (| (literal tramp-default-method-marker) (>= 2 alnum))))
@ -1070,7 +1070,10 @@ Used in `tramp-make-tramp-file-name'.")
"Regexp matching delimiter between method and user or host names.
Derived from `tramp-postfix-method-format'.")
(defconst tramp-user-regexp (rx (+ (not (any "/:|[]" blank))))
(defconst tramp-user-regexp
(rx (| (+ (not (any "/\\^$?*:;|[]{}()<>`'\"" blank)))
;; Environment variable.
(: "$" (+ (any "_" alnum)))))
"Regexp matching user names.")
(defconst tramp-prefix-domain-format "%"
@ -1845,6 +1848,8 @@ default values are used."
(hop (match-string (nth 5 tramp-file-name-structure) name))
domain port v)
(when user
(while (string-match (rx bos "$" (group (+ (any "_" alnum))) eos) user)
(setq user (getenv (match-string 1 user))))
(when (string-match tramp-user-with-domain-regexp user)
(setq domain (match-string 2 user)
user (match-string 1 user))))
@ -2705,9 +2710,9 @@ Fall back to normal file name handler if no Tramp file name handler exists."
;; `file-remote-p' is called for everything, even for symbolic
;; links which look remote. We don't want to get an error.
(non-essential (or non-essential (eq operation 'file-remote-p))))
(setq filename (tramp-replace-environment-variables filename))
(if (tramp-tramp-file-p filename)
(save-match-data
(setq filename (tramp-replace-environment-variables filename))
(with-parsed-tramp-file-name filename nil
(let ((current-connection tramp-current-connection)
(foreign
@ -6950,6 +6955,9 @@ to cache the result. Return the modified ATTR."
(caar attr))
(decode-coding-string
(match-string 1 (caar attr)) 'utf-8))))
;; Quote remote-like symlink.
(when (and (stringp (car attr)) (tramp-tramp-file-p (car attr)))
(setcar attr (file-name-quote (car attr) 'top)))
;; Set file's gid change bit.
(setcar
(nthcdr 9 attr)

89
test/lisp/net/tramp-tests.el
View file

@ -413,6 +413,7 @@ being the result.")
(should (tramp-tramp-file-p "/method:user@:"))
(should (tramp-tramp-file-p "/method:user@host:"))
(should (tramp-tramp-file-p "/method:user@email@host:"))
(should (tramp-tramp-file-p "/method:$USER@host:"))
;; Using a port.
(should (tramp-tramp-file-p "/method:host#1234:"))
@ -509,6 +510,7 @@ being the result.")
(should (tramp-tramp-file-p "/user@:"))
(should (tramp-tramp-file-p "/user@host:"))
(should (tramp-tramp-file-p "/user@email@host:"))
(should (tramp-tramp-file-p "/$USER@host:"))
;; Using a port.
(should (tramp-tramp-file-p "/host#1234:"))
@ -571,6 +573,7 @@ being the result.")
(should (tramp-tramp-file-p "/[method/user@]"))
(should (tramp-tramp-file-p "/[method/user@host]"))
(should (tramp-tramp-file-p "/[method/user@email@host]"))
(should (tramp-tramp-file-p "/[method/$USER@host]"))
;; Using a port.
(should (tramp-tramp-file-p "/[method/host#1234]"))
@ -759,6 +762,28 @@ being the result.")
(should (string-equal
(file-remote-p "/method:user@email@host:" 'hop) nil))
;; Expand environment variable. It can be cascaded.
(with-environment-variables
(("REMOTE_USER" "$REMOTE_USER1") ("REMOTE_USER1" "remote-user"))
(should (string-equal
(file-remote-p "/method:$REMOTE_USER@host:")
(format "/%s:%s@%s:" "method" "remote-user" "host")))
(should
(string-equal
(file-remote-p "/method:$REMOTE_USER@host:" 'method) "method"))
(should
(string-equal
(file-remote-p "/method:$REMOTE_USER@host:" 'user) "remote-user"))
(should
(string-equal
(file-remote-p "/method:$REMOTE_USER@host:" 'host) "host"))
(should
(string-equal
(file-remote-p "/method:$REMOTE_USER@host:" 'localname) ""))
(should
(string-equal
(file-remote-p "/method:$REMOTE_USER@host:" 'hop) nil)))
;; Expand `tramp-default-method' and `tramp-default-user'.
(should
(string-equal
@ -1239,6 +1264,28 @@ being the result.")
(should (string-equal
(file-remote-p "/user@email@host:" 'hop) nil))
;; Expand environment variable. It can be cascaded.
(with-environment-variables
(("REMOTE_USER" "$REMOTE_USER1") ("REMOTE_USER1" "remote-user"))
(should (string-equal
(file-remote-p "/$REMOTE_USER@host:")
(format "/%s@%s:" "remote-user" "host")))
(should
(string-equal
(file-remote-p "/$REMOTE_USER@host:" 'method) "default-method"))
(should
(string-equal
(file-remote-p "/$REMOTE_USER@host:" 'user) "remote-user"))
(should
(string-equal
(file-remote-p "/$REMOTE_USER@host:" 'host) "host"))
(should
(string-equal
(file-remote-p "/$REMOTE_USER@host:" 'localname) ""))
(should
(string-equal
(file-remote-p "/$REMOTE_USER@host:" 'hop) nil)))
;; Expand `tramp-default-method' and `tramp-default-user'.
(should (string-equal
(file-remote-p "/host#1234:")
@ -1715,6 +1762,28 @@ being the result.")
(should (string-equal
(file-remote-p "/[method/user@email@host]" 'hop) nil))
;; Expand environment variable. It can be cascaded.
(with-environment-variables
(("REMOTE_USER" "$REMOTE_USER1") ("REMOTE_USER1" "remote-user"))
(should (string-equal
(file-remote-p "/[method/$REMOTE_USER@host]")
(format "/[%s/%s@%s]" "method" "remote-user" "host")))
(should
(string-equal
(file-remote-p "/[method/$REMOTE_USER@host]" 'method) "method"))
(should
(string-equal
(file-remote-p "/[method/$REMOTE_USER@host]" 'user) "remote-user"))
(should
(string-equal
(file-remote-p "/[method/$REMOTE_USER@host]" 'host) "host"))
(should
(string-equal
(file-remote-p "/[method/$REMOTE_USER@host]" 'localname) ""))
(should
(string-equal
(file-remote-p "/[method/$REMOTE_USER@host]" 'hop) nil)))
;; Expand `tramp-default-method' and `tramp-default-user'.
(should (string-equal
(file-remote-p "/[/host#1234]")
@ -4582,15 +4651,19 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'."
(should (file-equal-p tmp-name1 tmp-name2))
;; Symbolic links could look like a remote file name.
;; They must be quoted then.
(let ((penguin
(if (eq tramp-syntax 'separate)
"/[penguin/motd]" "/penguin:motd:")))
(let ((penguin (pcase tramp-syntax
('default "/penguin:motd:")
('simplified "/motd:")
('separate "/[penguin/motd]"))))
(delete-file tmp-name2)
(make-symbolic-link
(funcall (if quoted #'file-name-unquote #'identity) penguin)
tmp-name2)
(should (file-symlink-p tmp-name2))
(should-not (file-regular-p tmp-name2))
(make-symbolic-link penguin tmp-name2)
(should
(string-equal
(file-attribute-type (file-attributes tmp-name2))
(file-name-quote penguin 'top)))
(should
(string-equal
(file-symlink-p tmp-name2) (file-name-quote penguin 'top)))
(should
(string-equal
(file-truename tmp-name2)