tramp-sshfs.el 15 KB
Newer Older
Michael Albinus's avatar
Michael Albinus committed
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52
;;; tramp-sshfs.el --- Tramp access functions via sshfs  -*- lexical-binding:t -*-

;; Copyright (C) 2021 Free Software Foundation, Inc.

;; Author: Michael Albinus <michael.albinus@gmx.de>
;; Keywords: comm, processes
;; Package: tramp

;; This file is part of GNU Emacs.

;; GNU Emacs is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.

;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs.  If not, see <https://www.gnu.org/licenses/>.

;;; Commentary:

;; sshfs is a program to mount a virtual file system, based on an sftp
;; connection.  Tramp uses its mount utility to access files and
;; directories there.

;; A remote file under sshfs control has the form
;; "/sshfs:user@host#port:/path/to/file".  User name and port number
;; are optional.

;;; Code:

(require 'tramp)
(require 'tramp-fuse)

;;;###tramp-autoload
(defconst tramp-sshfs-method "sshfs"
  "Tramp method for sshfs mounts.")

(defcustom tramp-sshfs-program "sshfs"
  "The sshfs mount command."
  :group 'tramp
  :version "28.1"
  :type 'string)

;;;###tramp-autoload
(tramp--with-startup
 (add-to-list 'tramp-methods
	      `(,tramp-sshfs-method
53 54 55 56 57 58 59 60 61 62 63 64 65
		(tramp-mount-args            (("-C") ("-p" "%p")
					      ("-o" "idmap=user,reconnect")))
		;; These are for remote processes.
                (tramp-login-program        "ssh")
                (tramp-login-args           (("-q")("-l" "%u") ("-p" "%p")
				             ("-e" "none") ("%h") ("%l")))
                (tramp-direct-async         t)
                (tramp-remote-shell         ,tramp-default-remote-shell)
                (tramp-remote-shell-login   ("-l"))
                (tramp-remote-shell-args    ("-c"))))

 (add-to-list 'tramp-connection-properties
	      `(,(format "/%s:" tramp-sshfs-method) "direct-async-process" t))
Michael Albinus's avatar
Michael Albinus committed
66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87

 (tramp-set-completion-function
  tramp-sshfs-method tramp-completion-function-alist-ssh))


;; New handlers should be added here.
;;;###tramp-autoload
(defconst tramp-sshfs-file-name-handler-alist
  '((access-file . tramp-handle-access-file)
    (add-name-to-file . tramp-handle-add-name-to-file)
    ;; `byte-compiler-base-file-name' performed by default handler.
    (copy-directory . tramp-handle-copy-directory)
    (copy-file . tramp-sshfs-handle-copy-file)
    (delete-directory . tramp-fuse-handle-delete-directory)
    (delete-file . tramp-fuse-handle-delete-file)
    ;; `diff-latest-backup-file' performed by default handler.
    (directory-file-name . tramp-handle-directory-file-name)
    (directory-files . tramp-fuse-handle-directory-files)
    (directory-files-and-attributes
     . tramp-handle-directory-files-and-attributes)
    (dired-compress-file . ignore)
    (dired-uncache . tramp-handle-dired-uncache)
88
    (exec-path . tramp-sshfs-handle-exec-path)
Michael Albinus's avatar
Michael Albinus committed
89 90 91 92 93 94 95 96 97 98
    (expand-file-name . tramp-handle-expand-file-name)
    (file-accessible-directory-p . tramp-handle-file-accessible-directory-p)
    (file-acl . ignore)
    (file-attributes . tramp-fuse-handle-file-attributes)
    (file-directory-p . tramp-handle-file-directory-p)
    (file-equal-p . tramp-handle-file-equal-p)
    (file-executable-p . tramp-fuse-handle-file-executable-p)
    (file-exists-p . tramp-handle-file-exists-p)
    (file-in-directory-p . tramp-handle-file-in-directory-p)
    (file-local-copy . tramp-handle-file-local-copy)
99
    (file-locked-p . tramp-handle-file-locked-p)
Michael Albinus's avatar
Michael Albinus committed
100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125
    (file-modes . tramp-handle-file-modes)
    (file-name-all-completions . tramp-fuse-handle-file-name-all-completions)
    (file-name-as-directory . tramp-handle-file-name-as-directory)
    (file-name-case-insensitive-p . tramp-handle-file-name-case-insensitive-p)
    (file-name-completion . tramp-handle-file-name-completion)
    (file-name-directory . tramp-handle-file-name-directory)
    (file-name-nondirectory . tramp-handle-file-name-nondirectory)
    ;; `file-name-sans-versions' performed by default handler.
    (file-newer-than-file-p . tramp-handle-file-newer-than-file-p)
    (file-notify-add-watch . ignore)
    (file-notify-rm-watch . ignore)
    (file-notify-valid-p . ignore)
    (file-ownership-preserved-p . ignore)
    (file-readable-p . tramp-fuse-handle-file-readable-p)
    (file-regular-p . tramp-handle-file-regular-p)
    (file-remote-p . tramp-handle-file-remote-p)
    (file-selinux-context . tramp-handle-file-selinux-context)
    (file-symlink-p . tramp-handle-file-symlink-p)
    (file-system-info . tramp-sshfs-handle-file-system-info)
    (file-truename . tramp-handle-file-truename)
    (file-writable-p . tramp-handle-file-writable-p)
    (find-backup-file-name . tramp-handle-find-backup-file-name)
    ;; `get-file-buffer' performed by default handler.
    (insert-directory . tramp-handle-insert-directory)
    (insert-file-contents . tramp-sshfs-handle-insert-file-contents)
    (load . tramp-handle-load)
126
    (lock-file . tramp-handle-lock-file)
Michael Albinus's avatar
Michael Albinus committed
127 128 129
    (make-auto-save-file-name . tramp-handle-make-auto-save-file-name)
    (make-directory . tramp-fuse-handle-make-directory)
    (make-directory-internal . ignore)
130
    (make-lock-file-name . tramp-handle-make-lock-file-name)
Michael Albinus's avatar
Michael Albinus committed
131
    (make-nearby-temp-file . tramp-handle-make-nearby-temp-file)
132
    (make-process . tramp-handle-make-process)
Michael Albinus's avatar
Michael Albinus committed
133
    (make-symbolic-link . tramp-handle-make-symbolic-link)
134
    (process-file . tramp-sshfs-handle-process-file)
Michael Albinus's avatar
Michael Albinus committed
135 136
    (rename-file . tramp-sshfs-handle-rename-file)
    (set-file-acl . ignore)
137
    (set-file-modes . tramp-sshfs-handle-set-file-modes)
Michael Albinus's avatar
Michael Albinus committed
138 139 140
    (set-file-selinux-context . ignore)
    (set-file-times . ignore)
    (set-visited-file-modtime . tramp-handle-set-visited-file-modtime)
141 142
    (shell-command . tramp-handle-shell-command)
    (start-file-process . tramp-handle-start-file-process)
Michael Albinus's avatar
Michael Albinus committed
143 144
    (substitute-in-file-name . tramp-handle-substitute-in-file-name)
    (temporary-file-directory . tramp-handle-temporary-file-directory)
145 146 147
    (tramp-get-remote-gid . ignore)
    (tramp-get-remote-uid . ignore)
    (tramp-set-file-uid-gid . ignore)
Michael Albinus's avatar
Michael Albinus committed
148
    (unhandled-file-name-directory . ignore)
149
    (unlock-file . tramp-handle-unlock-file)
Michael Albinus's avatar
Michael Albinus committed
150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200
    (vc-registered . ignore)
    (verify-visited-file-modtime . tramp-handle-verify-visited-file-modtime)
    (write-region . tramp-sshfs-handle-write-region))
"Alist of handler functions for Tramp SSHFS method.
Operations not mentioned here will be handled by the default Emacs primitives.")

;; It must be a `defsubst' in order to push the whole code into
;; tramp-loaddefs.el.  Otherwise, there would be recursive autoloading.
;;;###tramp-autoload
(defsubst tramp-sshfs-file-name-p (filename)
  "Check if it's a FILENAME for sshfs."
  (and (tramp-tramp-file-p filename)
       (string= (tramp-file-name-method (tramp-dissect-file-name filename))
	        tramp-sshfs-method)))

;;;###tramp-autoload
(defun tramp-sshfs-file-name-handler (operation &rest args)
  "Invoke the sshfs handler for OPERATION and ARGS.
First arg specifies the OPERATION, second arg is a list of
arguments to pass to the OPERATION."
  (if-let ((fn (assoc operation tramp-sshfs-file-name-handler-alist)))
      (save-match-data (apply (cdr fn) args))
    (tramp-run-real-handler operation args)))

;;;###tramp-autoload
(tramp--with-startup
 (tramp-register-foreign-file-name-handler
  #'tramp-sshfs-file-name-p #'tramp-sshfs-file-name-handler))


;; File name primitives.

(defun tramp-sshfs-handle-copy-file
    (filename newname &optional ok-if-already-exists keep-date
     preserve-uid-gid preserve-extended-attributes)
  "Like `copy-file' for Tramp files."
  (setq filename (expand-file-name filename)
	newname (expand-file-name newname))
  (if (file-directory-p filename)
      (copy-directory filename newname keep-date t)
    (copy-file
     (if (tramp-sshfs-file-name-p filename)
	 (tramp-fuse-local-file-name filename) filename)
     (if (tramp-sshfs-file-name-p newname)
	 (tramp-fuse-local-file-name newname) newname)
     ok-if-already-exists keep-date
     preserve-uid-gid preserve-extended-attributes)
    (when (tramp-sshfs-file-name-p newname)
      (with-parsed-tramp-file-name newname nil
	(tramp-flush-file-properties v localname)))))

201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216
(defun tramp-sshfs-handle-exec-path ()
  "Like `exec-path' for Tramp files."
  (append
   (with-parsed-tramp-file-name default-directory nil
     (with-tramp-connection-property (tramp-get-process v) "remote-path"
       (with-temp-buffer
	 (process-file "getconf" nil t nil "PATH")
	 (split-string
	  (progn
	    ;; Read the expression.
	    (goto-char (point-min))
	    (buffer-substring (point) (point-at-eol)))
	  ":" 'omit))))
   ;; The equivalent to `exec-directory'.
   `(,(tramp-file-local-name (expand-file-name default-directory)))))

Michael Albinus's avatar
Michael Albinus committed
217 218 219 220 221 222 223 224 225 226 227 228 229 230
(defun tramp-sshfs-handle-file-system-info (filename)
  "Like `file-system-info' for Tramp files."
  ;;`file-system-info' exists since Emacs 27.1.
  (tramp-compat-funcall 'file-system-info (tramp-fuse-local-file-name filename)))

(defun tramp-sshfs-handle-insert-file-contents
  (filename &optional visit beg end replace)
  "Like `insert-file-contents' for Tramp files."
  (let ((result
	 (insert-file-contents
	  (tramp-fuse-local-file-name filename) visit beg end replace)))
    (when visit (setq buffer-file-name filename))
    (cons (expand-file-name filename) (cdr result))))

231 232 233 234 235 236 237
(defun tramp-sshfs-handle-process-file
  (program &optional infile destination display &rest args)
  "Like `process-file' for Tramp files."
  ;; The implementation is not complete yet.
  (when (and (numberp destination) (zerop destination))
    (error "Implementation does not handle immediate return"))

238
  (with-parsed-tramp-file-name (expand-file-name default-directory) nil
239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258
    (let ((command
	   (format
	    "cd %s && exec %s"
	    localname
	    (mapconcat #'tramp-shell-quote-argument (cons program args) " "))))
      (unwind-protect
	  (apply
	   #'tramp-call-process
	   v (tramp-get-method-parameter v 'tramp-login-program)
	   infile destination display
	   (tramp-expand-args
	    v 'tramp-login-args
	    ?h (or (tramp-file-name-host v) "")
	    ?u (or (tramp-file-name-user v) "")
	    ?p (or (tramp-file-name-port v) "")
	    ?l command))

	(unless process-file-side-effects
          (tramp-flush-directory-properties v ""))))))

Michael Albinus's avatar
Michael Albinus committed
259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276
(defun tramp-sshfs-handle-rename-file
    (filename newname &optional ok-if-already-exists)
  "Like `rename-file' for Tramp files."
  (setq filename (expand-file-name filename)
	newname (expand-file-name newname))
  (rename-file
   (if (tramp-sshfs-file-name-p filename)
       (tramp-fuse-local-file-name filename) filename)
   (if (tramp-sshfs-file-name-p newname)
       (tramp-fuse-local-file-name newname) newname)
   ok-if-already-exists)
  (when (tramp-sshfs-file-name-p filename)
    (with-parsed-tramp-file-name filename nil
      (tramp-flush-file-properties v localname)))
  (when (tramp-sshfs-file-name-p newname)
    (with-parsed-tramp-file-name newname nil
      (tramp-flush-file-properties v localname))))

277 278 279 280 281
(defun tramp-sshfs-handle-set-file-modes (filename mode &optional flag)
  "Like `set-file-modes' for Tramp files."
  (with-parsed-tramp-file-name filename nil
    (unless (and (eq flag 'nofollow) (file-symlink-p filename))
      (tramp-flush-file-properties v localname)
Michael Albinus's avatar
Michael Albinus committed
282 283
      (tramp-compat-set-file-modes
       (tramp-fuse-local-file-name filename) mode flag))))
284

Michael Albinus's avatar
Michael Albinus committed
285
(defun tramp-sshfs-handle-write-region
286
  (start end filename &optional append visit lockname mustbenew)
Michael Albinus's avatar
Michael Albinus committed
287
  "Like `write-region' for Tramp files."
288 289
  (setq filename (expand-file-name filename)
	lockname (file-truename (or lockname filename)))
Michael Albinus's avatar
Michael Albinus committed
290 291 292 293 294 295 296 297
  (with-parsed-tramp-file-name filename nil
    (when (and mustbenew (file-exists-p filename)
	       (or (eq mustbenew 'excl)
		   (not
		    (y-or-n-p
		     (format "File %s exists; overwrite anyway? " filename)))))
      (tramp-error v 'file-already-exists filename))

298
    (let ((file-locked (eq (file-locked-p lockname) t)))
299 300

      ;; Lock file.
301 302
      (when (and (not (auto-save-file-name-p (file-name-nondirectory filename)))
		 (file-remote-p lockname)
303
		 (not file-locked))
304 305 306 307 308 309 310 311 312 313
	(setq file-locked t)
	;; `lock-file' exists since Emacs 28.1.
	(tramp-compat-funcall 'lock-file lockname))

      (let (create-lockfiles)
	(write-region
	 start end (tramp-fuse-local-file-name filename) append 'nomessage)
	(tramp-flush-file-properties v localname))

      ;; Unlock file.
314
      (when file-locked
315 316 317 318 319 320 321 322
	;; `unlock-file' exists since Emacs 28.1.
	(tramp-compat-funcall 'unlock-file lockname))

      ;; The end.
      (when (and (null noninteractive)
		 (or (eq visit t) (null visit) (stringp visit)))
	(tramp-message v 0 "Wrote %s" filename))
      (run-hooks 'tramp-handle-write-region-hook))))
Michael Albinus's avatar
Michael Albinus committed
323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344


;; File name conversions.

(defun tramp-sshfs-maybe-open-connection (vec)
  "Maybe open a connection VEC.
Does not do anything if a connection is already open, but re-opens the
connection if a previous connection has died for some reason."
  ;; During completion, don't reopen a new connection.
  (unless (tramp-connectable-p vec)
    (throw 'non-essential 'non-essential))

  ;; We need a process bound to the connection buffer.  Therefore, we
  ;; create a dummy process.  Maybe there is a better solution?
  (unless (get-buffer-process (tramp-get-connection-buffer vec))
    (let ((p (make-network-process
	      :name (tramp-get-connection-name vec)
	      :buffer (tramp-get-connection-buffer vec)
	      :server t :host 'local :service t :noquery t)))
      (process-put p 'vector vec)
      (set-process-query-on-exit-flag p nil)

345 346 347
      ;; Mark process for filelock.
      (tramp-set-connection-property p "lock-pid" (truncate (time-to-seconds)))

Michael Albinus's avatar
Michael Albinus committed
348 349 350 351 352 353 354 355 356
      ;; Set connection-local variables.
      (tramp-set-connection-local-variables vec)

      ;; Create directory.
      (unless (file-directory-p (tramp-fuse-mount-point vec))
	(make-directory (tramp-fuse-mount-point vec) 'parents))

      (unless
	  (or (tramp-fuse-mounted-p vec)
357 358 359 360 361 362 363 364 365 366
	      (with-temp-buffer
		(zerop
		 (apply
		  #'tramp-call-process
		  vec tramp-sshfs-program nil t nil
		  (tramp-fuse-mount-spec vec)
		  (tramp-fuse-mount-point vec)
		  (tramp-expand-args
		   vec 'tramp-mount-args
		   ?p (or (tramp-file-name-port vec) "")))))
Michael Albinus's avatar
Michael Albinus committed
367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391
	  (tramp-error
	   vec 'file-error "Error mounting %s" (tramp-fuse-mount-spec vec))))

      ;; Mark it as connected.
      (tramp-set-connection-property
       (tramp-get-connection-process vec) "connected" t)))

  ;; In `tramp-check-cached-permissions', the connection properties
  ;; "{uid,gid}-{integer,string}" are used.  We set them to proper values.
  (with-tramp-connection-property
      vec "uid-integer" (tramp-get-local-uid 'integer))
  (with-tramp-connection-property
      vec "gid-integer" (tramp-get-local-gid 'integer))
  (with-tramp-connection-property
      vec "uid-string" (tramp-get-local-uid 'string))
  (with-tramp-connection-property
      vec "gid-string" (tramp-get-local-gid 'string)))

(add-hook 'tramp-unload-hook
	  (lambda ()
	    (unload-feature 'tramp-sshfs 'force)))

(provide 'tramp-sshfs)

;;; tramp-sshfs.el ends here