lisp/net/tramp-imap.el

   1 ;;; tramp-imap.el --- Tramp interface to IMAP through imap.el
   2
   3 ;; Copyright (C) 2009, 2010 Free Software Foundation, Inc.
   4
   5 ;; Author: Teodor Zlatanov <tzz@lifelogs.com>
   6 ;; Keywords: mail, comm
   7 ;; Package: tramp
   8
   9 ;; This file is part of GNU Emacs.
  10
  11 ;; GNU Emacs is free software: you can redistribute it and/or modify
  12 ;; it under the terms of the GNU General Public License as published by
  13 ;; the Free Software Foundation, either version 3 of the License, or
  14 ;; (at your option) any later version.
  15
  16 ;; GNU Emacs is distributed in the hope that it will be useful,
  17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19 ;; GNU General Public License for more details.
  20
  21 ;; You should have received a copy of the GNU General Public License
  22 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
  23
  24 ;;; Commentary:
  25
  26 ;; Package to provide Tramp over IMAP
  27
  28 ;;; Setup:
  29
  30 ;; just load and open files, e.g.
  31 ;; /imaps:user@yourhosthere.com:/INBOX.test/1
  32 ;; or
  33 ;; /imap:user@yourhosthere.com:/INBOX.test/1
  34
  35 ;; where `imap' goes over IMAP, while `imaps' goes over IMAP+SSL
  36
  37 ;; This module will use imap-hash.el to access the IMAP mailbox.
  38
  39 ;; This module will use auth-source.el to authenticate against the
  40 ;; IMAP server, PLUS it will use auth-source.el to get your passphrase
  41 ;; for the symmetrically encrypted messages.  For the former, use the
  42 ;; usual IMAP ports.  For the latter, use the port "tramp-imap".
  43
  44 ;; example .authinfo / .netrc file:
  45
  46 ;; machine yourhosthere.com port tramp-imap login USER password SYMMETRIC-PASSPHRASE
  47
  48 ;; note above is the symmetric encryption passphrase for GPG
  49 ;; below is the regular password for IMAP itself and other things on that host
  50
  51 ;; machine yourhosthere.com login USER password NORMAL-PASSWORD
  52
  53
  54 ;;; Code:
  55
  56 (require 'assoc)
  57 (require 'tramp)
  58 (require 'tramp-compat)
  59
  60 (autoload 'auth-source-user-or-password "auth-source")
  61 (autoload 'epg-context-operation "epg")
  62 (autoload 'epg-context-set-armor "epg")
  63 (autoload 'epg-context-set-passphrase-callback "epg")
  64 (autoload 'epg-context-set-progress-callback "epg")
  65 (autoload 'epg-decrypt-string "epg")
  66 (autoload 'epg-encrypt-string "epg")
  67 (autoload 'epg-make-context "epg")
  68 (autoload 'imap-hash-get "imap-hash")
  69 (autoload 'imap-hash-make "imap-hash")
  70 (autoload 'imap-hash-map "imap-hash")
  71 (autoload 'imap-hash-put "imap-hash")
  72 (autoload 'imap-hash-rem "imap-hash")
  73
  74 ;; We use the additional header "X-Size" for encoding the size of a file.
  75 (eval-after-load "imap-hash"
  76   '(add-to-list 'imap-hash-headers 'X-Size 'append))
  77
  78 ;; Define Tramp IMAP method ...
  79 (defconst tramp-imap-method "imap"
  80   "*Method to connect via IMAP protocol.")
  81
  82 (add-to-list 'tramp-methods (list tramp-imap-method '(tramp-default-port 143)))
  83
  84 ;; Add a default for `tramp-default-user-alist'.  Default is the local user.
  85 (add-to-list 'tramp-default-user-alist
  86              `(,tramp-imap-method nil ,(user-login-name)))
  87
  88 ;; Define Tramp IMAPS method ...
  89 (defconst tramp-imaps-method "imaps"
  90   "*Method to connect via secure IMAP protocol.")
  91
  92 ;; ... and add it to the method list.
  93 (add-to-list 'tramp-methods (list tramp-imaps-method '(tramp-default-port 993)))
  94
  95 ;; Add a default for `tramp-default-user-alist'.  Default is the local user.
  96 (add-to-list 'tramp-default-user-alist
  97              `(,tramp-imaps-method nil ,(user-login-name)))
  98
  99 ;; Add completion function for IMAP method.
 100 ;; (tramp-set-completion-function
 101 ;;  tramp-imap-method tramp-completion-function-alist-ssh) ; TODO: test this
 102 ;;  tramp-imaps-method tramp-completion-function-alist-ssh) ; TODO: test this
 103
 104 ;; New handlers should be added here.
 105 (defconst tramp-imap-file-name-handler-alist
 106   '(
 107     ;; `access-file' performed by default handler
 108     (add-name-to-file . ignore)
 109     ;; `byte-compiler-base-file-name' performed by default handler
 110     ;; `copy-directory' performed by default handler
 111     (copy-file . tramp-imap-handle-copy-file)
 112     (delete-directory . ignore) ;; tramp-imap-handle-delete-directory)
 113     (delete-file . tramp-imap-handle-delete-file)
 114     ;; `diff-latest-backup-file' performed by default handler
 115     (directory-file-name . tramp-handle-directory-file-name)
 116     (directory-files . tramp-handle-directory-files)
 117     (directory-files-and-attributes
 118      . tramp-imap-handle-directory-files-and-attributes)
 119     (dired-call-process . ignore)
 120     ;; `dired-compress-file' performed by default handler
 121     ;; `dired-uncache' performed by default handler
 122     (expand-file-name . tramp-imap-handle-expand-file-name)
 123     ;; `file-accessible-directory-p' performed by default handler
 124     (file-attributes . tramp-imap-handle-file-attributes)
 125     (file-directory-p .  tramp-imap-handle-file-directory-p)
 126     (file-executable-p . tramp-imap-handle-file-executable-p)
 127     (file-exists-p . tramp-imap-handle-file-exists-p)
 128     (file-local-copy . tramp-imap-handle-file-local-copy)
 129     (file-modes . tramp-handle-file-modes)
 130     (file-name-all-completions . tramp-imap-handle-file-name-all-completions)
 131     (file-name-as-directory . tramp-handle-file-name-as-directory)
 132     (file-name-completion . tramp-handle-file-name-completion)
 133     (file-name-directory . tramp-handle-file-name-directory)
 134     (file-name-nondirectory . tramp-handle-file-name-nondirectory)
 135     ;; `file-name-sans-versions' performed by default handler
 136     (file-newer-than-file-p . tramp-imap-handle-file-newer-than-file-p)
 137     (file-ownership-preserved-p . ignore)
 138     (file-readable-p . tramp-imap-handle-file-readable-p)
 139     (file-regular-p . tramp-handle-file-regular-p)
 140     (file-remote-p . tramp-handle-file-remote-p)
 141     ;; `file-selinux-context' performed by default handler.
 142     (file-symlink-p . tramp-handle-file-symlink-p)
 143     ;; `file-truename' performed by default handler
 144     (file-writable-p . tramp-imap-handle-file-writable-p)
 145     (find-backup-file-name . tramp-handle-find-backup-file-name)
 146     ;; `find-file-noselect' performed by default handler
 147     ;; `get-file-buffer' performed by default handler
 148     (insert-directory . tramp-imap-handle-insert-directory)
 149     (insert-file-contents . tramp-imap-handle-insert-file-contents)
 150     (load . tramp-handle-load)
 151     (make-directory . ignore) ;; tramp-imap-handle-make-directory)
 152     (make-directory-internal . ignore) ;; tramp-imap-handle-make-directory-internal)
 153     (make-symbolic-link . ignore)
 154     (rename-file . tramp-imap-handle-rename-file)
 155     (set-file-modes . ignore)
 156     ;; `set-file-selinux-context' performed by default handler.
 157     (set-file-times . ignore) ;; tramp-imap-handle-set-file-times)
 158     (set-visited-file-modtime . ignore)
 159     (shell-command . ignore)
 160     (substitute-in-file-name . tramp-handle-substitute-in-file-name)
 161     (unhandled-file-name-directory . tramp-handle-unhandled-file-name-directory)
 162     (vc-registered . ignore)
 163     (verify-visited-file-modtime . ignore)
 164     (write-region . tramp-imap-handle-write-region)
 165     (executable-find . ignore)
 166     (start-file-process . ignore)
 167     (process-file . ignore)
 168 )
 169   "Alist of handler functions for Tramp IMAP method.
 170 Operations not mentioned here will be handled by the default Emacs primitives.")
 171
 172 (defgroup tramp-imap nil
 173   "Tramp over IMAP configuration."
 174   :version "23.2"
 175   :group 'tramp)
 176
 177 (defcustom tramp-imap-subject-marker "tramp-imap-subject-marker"
 178   "The subject marker that Tramp-IMAP will use."
 179   :type 'string
 180   :version "23.2"
 181   :group 'tramp-imap)
 182
 183 ;; TODO: these will be defcustoms later.
 184 (defvar tramp-imap-passphrase-cache nil) ;; can be t or 'never
 185 (defvar tramp-imap-passphrase nil)
 186
 187 (defun tramp-imap-file-name-p (filename)
 188   "Check if it's a filename for IMAP protocol."
 189   (let ((v (tramp-dissect-file-name filename)))
 190     (or
 191      (string= (tramp-file-name-method v) tramp-imap-method)
 192      (string= (tramp-file-name-method v) tramp-imaps-method))))
 193
 194 (defun tramp-imap-file-name-handler (operation &rest args)
 195   "Invoke the IMAP related OPERATION.
 196 First arg specifies the OPERATION, second arg is a list of arguments to
 197 pass to the OPERATION."
 198   (let ((fn (assoc operation tramp-imap-file-name-handler-alist)))
 199     (if fn
 200         (save-match-data (apply (cdr fn) args))
 201       (tramp-run-real-handler operation args))))
 202
 203 (add-to-list 'tramp-foreign-file-name-handler-alist
 204              (cons 'tramp-imap-file-name-p 'tramp-imap-file-name-handler))
 205
 206 (defun tramp-imap-handle-copy-file
 207   (filename newname &optional ok-if-already-exists keep-date
 208             preserve-uid-gid preserve-selinux-context)
 209   "Like `copy-file' for Tramp files."
 210   (tramp-imap-do-copy-or-rename-file
 211    'copy filename newname ok-if-already-exists keep-date preserve-uid-gid))
 212
 213 (defun tramp-imap-handle-rename-file
 214   (filename newname &optional ok-if-already-exists)
 215   "Like `rename-file' for Tramp files."
 216   (tramp-imap-do-copy-or-rename-file
 217    'rename filename newname ok-if-already-exists t t))
 218
 219 (defun tramp-imap-do-copy-or-rename-file
 220   (op filename newname &optional ok-if-already-exists keep-date preserve-uid-gid)
 221   "Copy or rename a remote file.
 222 OP must be `copy' or `rename' and indicates the operation to perform.
 223 FILENAME specifies the file to copy or rename, NEWNAME is the name of
 224 the new file (for copy) or the new name of the file (for rename).
 225 OK-IF-ALREADY-EXISTS means don't barf if NEWNAME exists already.
 226 KEEP-DATE means to make sure that NEWNAME has the same timestamp
 227 as FILENAME.  PRESERVE-UID-GID, when non-nil, instructs to keep
 228 the uid and gid if both files are on the same host.
 229
 230 This function is invoked by `tramp-imap-handle-copy-file' and
 231 `tramp-imap-handle-rename-file'.  It is an error if OP is neither
 232 of `copy' and `rename'."
 233   (unless (memq op '(copy rename))
 234     (error "Unknown operation `%s', must be `copy' or `rename'" op))
 235   (setq filename (expand-file-name filename))
 236   (setq newname (expand-file-name newname))
 237   (when (file-directory-p newname)
 238     (setq newname (expand-file-name (file-name-nondirectory filename) newname)))
 239
 240   (let ((t1 (and (tramp-tramp-file-p filename)
 241                  (tramp-imap-file-name-p filename)))
 242         (t2 (and (tramp-tramp-file-p newname)
 243                  (tramp-imap-file-name-p newname))))
 244
 245     (with-parsed-tramp-file-name (if t1 filename newname) nil
 246       (when (and (not ok-if-already-exists) (file-exists-p newname))
 247         (tramp-error
 248          v 'file-already-exists "File %s already exists" newname))
 249
 250       (with-progress-reporter
 251           v 0 (format "%s %s to %s"
 252                       (if (eq op 'copy) "Copying" "Renaming")
 253                       filename newname)
 254
 255         ;; We just make a local copy of FILENAME, and write it then to
 256         ;; NEWNAME.  This must be optimized, when both files are
 257         ;; located on the same IMAP server.
 258         (with-temp-buffer
 259           (if (and t1 t2)
 260               ;; We don't encrypt.
 261               (with-parsed-tramp-file-name newname v1
 262                 (insert (tramp-imap-get-file filename nil))
 263                 (tramp-imap-put-file
 264                  v1 (current-buffer)
 265                  (tramp-imap-file-name-name v1)
 266                  nil nil (nth 7 (file-attributes filename))))
 267             ;; One of them is not located on a IMAP mailbox.
 268             (insert-file-contents filename)
 269             (write-region (point-min) (point-max) newname)))))
 270
 271     (when (eq op 'rename) (delete-file filename))))
 272
 273 ;; TODO: revise this much
 274 (defun tramp-imap-handle-expand-file-name (name &optional dir)
 275   "Like `expand-file-name' for Tramp files."
 276   ;; If DIR is not given, use DEFAULT-DIRECTORY or "/".
 277   (setq dir (or dir default-directory "/"))
 278   ;; Unless NAME is absolute, concat DIR and NAME.
 279   (unless (file-name-absolute-p name)
 280     (setq name (concat (file-name-as-directory dir) name)))
 281   ;; If NAME is not a Tramp file, run the real handler.
 282   (if (or (tramp-completion-mode-p) (not (tramp-tramp-file-p name)))
 283       (tramp-drop-volume-letter
 284        (tramp-run-real-handler 'expand-file-name (list name nil)))
 285     ;; Dissect NAME.
 286     (with-parsed-tramp-file-name name nil
 287       (unless (tramp-run-real-handler 'file-name-absolute-p (list localname))
 288         (setq localname (concat "/" localname)))
 289       ;; There might be a double slash, for example when "~/"
 290       ;; expands to "/".  Remove this.
 291       (while (string-match "//" localname)
 292         (setq localname (replace-match "/" t t localname)))
 293       ;; Do normal `expand-file-name' (this does "/./" and "/../").
 294       ;; We bind `directory-sep-char' here for XEmacs on Windows,
 295       ;; which would otherwise use backslash.  `default-directory' is
 296       ;; bound, because on Windows there would be problems with UNC
 297       ;; shares or Cygwin mounts.
 298       (let ((default-directory (tramp-compat-temporary-file-directory)))
 299         (tramp-make-tramp-file-name
 300          method user host
 301          (tramp-drop-volume-letter
 302           (tramp-run-real-handler
 303            'expand-file-name (list localname))))))))
 304
 305 ;; This function should return "foo/" for directories and "bar" for
 306 ;; files.
 307 (defun tramp-imap-handle-file-name-all-completions (filename directory)
 308   "Like `file-name-all-completions' for Tramp files."
 309   (all-completions
 310    filename
 311    (with-parsed-tramp-file-name (expand-file-name directory) nil
 312      (save-match-data
 313        (let ((entries
 314               (tramp-imap-get-file-entries v localname)))
 315          (mapcar
 316           (lambda (x)
 317             (list
 318              (if (string-match "d" (nth 9 x))
 319                  (file-name-as-directory (nth 0 x))
 320                (nth 0 x))))
 321           entries))))))
 322
 323 (defun tramp-imap-get-file-entries (vec localname &optional exact)
 324   "Read entries returned by IMAP server. EXACT limits to exact matches.
 325 Result is a list of (LOCALNAME LINK COUNT UID GID ATIME MTIME CTIME
 326 SIZE MODE WEIRD INODE DEVICE)."
 327   (tramp-message vec 5 "working on %s" localname)
 328   (let* ((name (tramp-imap-file-name-name vec))
 329          (search-name (or name ""))
 330          (search-name (if exact (concat search-name "$") search-name))
 331          (iht (tramp-imap-make-iht vec search-name)))
 332 ;; TODO: catch errors
 333     ;; (tramp-error vec 'none "bad name %s or mailbox %s" name mbox))
 334     (imap-hash-map (lambda (uid headers body)
 335                      (let ((subject (substring
 336                                      (aget headers 'Subject "")
 337                                      (length tramp-imap-subject-marker)))
 338                            (from (aget headers 'From ""))
 339                            (date (date-to-time (aget headers 'Date "")))
 340                            (size (string-to-number
 341                                   (or (aget headers 'X-Size "0") "0"))))
 342                        (setq from
 343                              (if (string-match "<\\([^@]+\\)@" from)
 344                                  (match-string 1 from)
 345                                "nobody"))
 346                        (list
 347                         subject
 348                         nil
 349                         -1
 350                         from
 351                         "nogroup"
 352                         date
 353                         date
 354                         date
 355                         size
 356                         "-rw-rw-rw-"
 357                         nil
 358                         uid
 359                         (tramp-get-device vec))))
 360                    iht t)))
 361
 362 (defun tramp-imap-handle-write-region (start end filename &optional append visit lockname confirm)
 363   "Like `write-region' for Tramp files."
 364   (setq filename (expand-file-name filename))
 365   (with-parsed-tramp-file-name filename nil
 366     ;; XEmacs takes a coding system as the seventh argument, not `confirm'.
 367     (when (and (not (featurep 'xemacs))
 368                confirm (file-exists-p filename))
 369       (unless (y-or-n-p (format "File %s exists; overwrite anyway? "
 370                                 filename))
 371         (tramp-error v 'file-error "File not overwritten")))
 372     (tramp-flush-file-property v localname)
 373     (let* ((old-buffer (current-buffer))
 374            (inode (tramp-imap-get-file-inode filename))
 375            (min 1)
 376            (max (point-max))
 377            ;; Make sure we have good start and end values.
 378            (start (or start min))
 379            (end (or end max))
 380            temp-buffer)
 381       (with-temp-buffer
 382         (setq temp-buffer (if (and (eq start min) (eq end max))
 383                               old-buffer
 384                             ;; If this is a region write, insert the substring.
 385                             (insert
 386                              (with-current-buffer old-buffer
 387                                (buffer-substring-no-properties start end)))
 388                             (current-buffer)))
 389         (tramp-imap-put-file v
 390                              temp-buffer
 391                              (tramp-imap-file-name-name v)
 392                              inode
 393                              t)))
 394     (when (eq visit t)
 395       (set-visited-file-modtime))))
 396
 397 (defun tramp-imap-handle-insert-directory
 398   (filename switches &optional wildcard full-directory-p)
 399   "Like `insert-directory' for Tramp files."
 400   (setq filename (expand-file-name filename))
 401   (if full-directory-p
 402       ;; Called from `dired-add-entry'.
 403       (setq filename (file-name-as-directory filename))
 404     (setq filename (directory-file-name filename)))
 405   (with-parsed-tramp-file-name filename nil
 406     (save-match-data
 407       (let ((base (file-name-nondirectory localname))
 408             (entries (copy-sequence
 409                       (tramp-imap-get-file-entries
 410                        v (file-name-directory localname)))))
 411
 412         (when wildcard
 413           (when (string-match "\\." base)
 414             (setq base (replace-match "\\\\." nil nil base)))
 415           (when (string-match "\\*" base)
 416             (setq base (replace-match ".*" nil nil base)))
 417           (when (string-match "\\?" base)
 418             (setq base (replace-match ".?" nil nil base))))
 419
 420         ;; Filter entries.
 421         (setq entries
 422               (delq
 423                nil
 424                (if (or wildcard (zerop (length base)))
 425                    ;; Check for matching entries.
 426                    (mapcar
 427                     (lambda (x)
 428                       (when (string-match
 429                              (format "^%s" base) (nth 0 x))
 430                         x))
 431                     entries)
 432                  ;; We just need the only and only entry FILENAME.
 433                  (list (assoc base entries)))))
 434
 435         ;; Sort entries.
 436         (setq entries
 437               (sort
 438                entries
 439                (lambda (x y)
 440                  (if (string-match "t" switches)
 441                      ;; Sort by date.
 442                      (tramp-time-less-p (nth 6 y) (nth 6 x))
 443                    ;; Sort by name.
 444                    (string-lessp (nth 0 x) (nth 0 y))))))
 445
 446         ;; Handle "-F" switch.
 447         (when (string-match "F" switches)
 448           (mapc
 449            (lambda (x)
 450              (when (not (zerop (length (car x))))
 451                (cond
 452                 ((char-equal ?d (string-to-char (nth 9 x)))
 453                  (setcar x (concat (car x) "/")))
 454                 ((char-equal ?x (string-to-char (nth 9 x)))
 455                  (setcar x (concat (car x) "*"))))))
 456            entries))
 457
 458         ;; Print entries.
 459         (mapcar
 460          (lambda (x)
 461            (when (not (zerop (length (nth 0 x))))
 462              (insert
 463               (format
 464                "%10s %3d %-8s %-8s %8s %s "
 465                (nth 9 x) ; mode
 466                (nth 11 x) ; inode
 467                (nth 3 x) ; uid
 468                (nth 4 x) ; gid
 469                (nth 8 x) ; size
 470                (format-time-string
 471                 (if (tramp-time-less-p
 472                      (tramp-time-subtract (current-time) (nth 6 x))
 473                      tramp-half-a-year)
 474                     "%b %e %R"
 475                   "%b %e  %Y")
 476                 (nth 6 x)))) ; date
 477              ;; For the file name, we set the `dired-filename'
 478              ;; property.  This allows to handle file names with
 479              ;; leading or trailing spaces as well.  The inserted name
 480              ;; could be from somewhere else, so we use the relative
 481              ;; file name of `default-directory'.
 482              (let ((pos (point)))
 483                (insert
 484                 (format
 485                  "%s\n"
 486                  (file-relative-name
 487                   (expand-file-name (nth 0 x) (file-name-directory filename)))))
 488                (put-text-property pos (1- (point)) 'dired-filename t))
 489              (forward-line)
 490              (beginning-of-line)))
 491          entries)))))
 492
 493 (defun tramp-imap-handle-insert-file-contents
 494   (filename &optional visit beg end replace)
 495   "Like `insert-file-contents' for Tramp files."
 496   (barf-if-buffer-read-only)
 497   (when visit
 498     (setq buffer-file-name (expand-file-name filename))
 499     (set-visited-file-modtime)
 500     (set-buffer-modified-p nil))
 501   (with-parsed-tramp-file-name filename nil
 502     (if (not (file-exists-p filename))
 503         (tramp-error
 504          v 'file-error "File `%s' not found on remote host" filename)
 505       (let ((point (point))
 506             size data)
 507         (with-progress-reporter v 3 (format "Fetching file %s" filename)
 508           (insert (tramp-imap-get-file filename t))
 509           (setq size (- (point) point))
 510 ;;; TODO: handle ranges.
 511 ;;;            (let ((beg (or beg (point-min)))
 512 ;;;                (end (min (or end (point-max)) (point-max))))
 513 ;;;              (setq size (- end beg))
 514 ;;;            (buffer-substring beg end))
 515           (goto-char point)
 516           (list (expand-file-name filename) size))))))
 517
 518 (defun tramp-imap-handle-file-exists-p (filename)
 519   "Like `file-exists-p' for Tramp files."
 520   (and (file-attributes filename) t))
 521
 522 (defun tramp-imap-handle-file-directory-p (filename)
 523   "Like `file-directory-p' for Tramp-IMAP files."
 524   ;; We allow only mailboxes to be a directory.
 525   (with-parsed-tramp-file-name (expand-file-name filename default-directory) nil
 526     (and (string-match "^/[^/]*$" (directory-file-name localname)) t)))
 527
 528 (defun tramp-imap-handle-file-attributes (filename &optional id-format)
 529   "Like `file-attributes' for Tramp-IMAP FILENAME."
 530   (with-parsed-tramp-file-name (expand-file-name filename) nil
 531     (let ((res (cdr-safe (nth 0 (tramp-imap-get-file-entries v localname)))))
 532       (unless (or (null res) (eq id-format 'string))
 533         (setcar (nthcdr 2 res) 1)
 534         (setcar (nthcdr 3 res) 1))
 535       res)))
 536
 537 (defun tramp-imap-get-file-inode (filename &optional id-format)
 538   "Get inode equivalent \(actually the UID) for Tramp-IMAP FILENAME."
 539   (nth 10 (tramp-compat-file-attributes filename id-format)))
 540
 541 (defun tramp-imap-handle-file-executable-p (filename)
 542   "Like `file-executable-p' for Tramp files.  False for IMAP."
 543   nil)
 544
 545 (defun tramp-imap-handle-file-readable-p (filename)
 546   "Like `file-readable-p' for Tramp files.  True for IMAP."
 547   (file-exists-p filename))
 548
 549 (defun tramp-imap-handle-file-writable-p (filename)
 550   "Like `file-writable-p' for Tramp files.  True for IMAP."
 551   ;; `file-exists-p' does not work yet for directories.
 552   ;; (file-exists-p (file-name-directory filename)))
 553   (file-directory-p (file-name-directory filename)))
 554
 555 (defun tramp-imap-handle-delete-file (filename &optional trash)
 556   "Like `delete-file' for Tramp files."
 557   (cond
 558    ((not (file-exists-p filename)) nil)
 559    (t (with-parsed-tramp-file-name (expand-file-name filename) nil
 560         (let ((iht (tramp-imap-make-iht v)))
 561           (imap-hash-rem (tramp-imap-get-file-inode filename) iht))))))
 562
 563 (defun tramp-imap-handle-directory-files-and-attributes
 564   (directory &optional full match nosort id-format)
 565   "Like `directory-files-and-attributes' for Tramp files."
 566   (mapcar
 567    (lambda (x)
 568      (cons x (tramp-compat-file-attributes
 569               (if full x (expand-file-name x directory)) id-format)))
 570    (directory-files directory full match nosort)))
 571
 572 ;; TODO: fix this in tramp-imap-get-file-entries.
 573 (defun tramp-imap-handle-file-newer-than-file-p (file1 file2)
 574   "Like `file-newer-than-file-p' for Tramp files."
 575   (cond
 576    ((not (file-exists-p file1)) nil)
 577    ((not (file-exists-p file2)) t)
 578    (t (tramp-time-less-p (nth 5 (file-attributes file2))
 579                          (nth 5 (file-attributes file1))))))
 580
 581 (defun tramp-imap-handle-file-local-copy (filename)
 582   "Like `file-local-copy' for Tramp files."
 583   (with-parsed-tramp-file-name (expand-file-name filename) nil
 584     (unless (file-exists-p filename)
 585       (tramp-error
 586        v 'file-error
 587        "Cannot make local copy of non-existing file `%s'" filename))
 588     (let ((tmpfile (tramp-compat-make-temp-file filename)))
 589       (with-progress-reporter
 590           v 3 (format "Fetching %s to tmp file %s" filename tmpfile)
 591         (with-temp-buffer
 592           (insert-file-contents filename)
 593           (write-region (point-min) (point-max) tmpfile)
 594           tmpfile)))))
 595
 596 (defun tramp-imap-put-file
 597   (vec filename-or-buffer &optional subject inode encode size)
 598   "Write contents of FILENAME-OR-BUFFER to Tramp-IMAP file VEC with name SUBJECT.
 599 When INODE is given, delete that old remote file after writing the new one
 600 \(normally this is the old file with the same name).  A non-nil ENCODE
 601 forces the encoding of the buffer or file.  SIZE, when available, indicates
 602 the file size; this is needed, if the file or buffer is already encoded."
 603   ;; `tramp-current-host' is used in `tramp-imap-passphrase-callback-function'.
 604   (let ((tramp-current-host (tramp-file-name-real-host vec))
 605         (iht (tramp-imap-make-iht vec)))
 606     (imap-hash-put (list
 607                     (list (cons
 608                            'Subject
 609                            (format
 610                             "%s%s"
 611                             tramp-imap-subject-marker
 612                             (or subject "no subject")))
 613                           (cons
 614                            'X-Size
 615                            (number-to-string
 616                             (cond
 617                              ((numberp size) size)
 618                              ((bufferp filename-or-buffer)
 619                               (buffer-size filename-or-buffer))
 620                              ((stringp filename-or-buffer)
 621                               (nth 7 (file-attributes filename-or-buffer)))
 622                              ;; We don't know the size.
 623                              (t -1)))))
 624                     (cond ((bufferp filename-or-buffer)
 625                            (with-current-buffer filename-or-buffer
 626                              (if encode
 627                                  (tramp-imap-encode-buffer)
 628                                (buffer-string))))
 629                           ;; TODO: allow file names.
 630                           (t "No body available")))
 631                    iht
 632                    inode)))
 633
 634 (defun tramp-imap-get-file (filename &optional decode)
 635   ;; (debug (tramp-imap-get-file-inode filename))
 636   (with-parsed-tramp-file-name (expand-file-name filename) nil
 637     (condition-case ()
 638         ;; `tramp-current-host' is used in
 639         ;; `tramp-imap-passphrase-callback-function'.
 640         (let* ((tramp-current-host (tramp-file-name-real-host v))
 641                (iht (tramp-imap-make-iht v))
 642                (inode (tramp-imap-get-file-inode filename))
 643                (data (imap-hash-get inode iht t)))
 644           (if decode
 645               (with-temp-buffer
 646                 (insert (nth 1 data))
 647                 ;;(debug inode (buffer-string))
 648                 (tramp-imap-decode-buffer))
 649             (nth 1 data)))
 650       (error (tramp-error
 651               v 'file-error "File `%s' could not be read" filename)))))
 652
 653 (defun tramp-imap-passphrase-callback-function (context key-id handback)
 654   "Called by EPG to get a passphrase for Tramp-IMAP.
 655 CONTEXT is the encryption/decryption EPG context.
 656 HANDBACK is just carried through.
 657 KEY-ID can be 'SYM or 'PIN among others."
 658   (let* ((server tramp-current-host)
 659          (port "tramp-imap")            ; this is NOT the server password!
 660          (auth-passwd
 661           (auth-source-user-or-password "password" server port)))
 662     (or
 663      (copy-sequence auth-passwd)
 664      ;; If we cache the passphrase and we have one.
 665      (if (and (eq tramp-imap-passphrase-cache t)
 666               tramp-imap-passphrase)
 667          ;; Do we reuse it?
 668          (if (y-or-n-p "Reuse the passphrase? ")
 669              (copy-sequence tramp-imap-passphrase)
 670            ;; Don't reuse: revert caching behavior to nil, erase passphrase,
 671            ;; call ourselves again.
 672            (setq tramp-imap-passphrase-cache nil)
 673            (setq tramp-imap-passphrase nil)
 674            (tramp-imap-passphrase-callback-function context key-id handback))
 675        (let ((p (if (eq key-id 'SYM)
 676                     (read-passwd
 677                      "Tramp-IMAP passphrase for symmetric encryption: "
 678                      (eq (epg-context-operation context) 'encrypt)
 679                      tramp-imap-passphrase)
 680                   (read-passwd
 681                    (if (eq key-id 'PIN)
 682                        "Tramp-IMAP passphrase for PIN: "
 683                      (let ((entry (assoc key-id
 684                                          (symbol-value 'epg-user-id-alist))))
 685                        (if entry
 686                            (format "Tramp-IMAP passphrase for %s %s: "
 687                                    key-id (cdr entry))
 688                          (format "Tramp-IMAP passphrase for %s: " key-id))))
 689                    nil
 690                    tramp-imap-passphrase))))
 691
 692          ;; If we have an answer, the passphrase has changed,
 693          ;; the user hasn't declined keeping the passphrase,
 694          ;; and they answer yes to keep it now...
 695          (when (and
 696                 p
 697                 (not (equal tramp-imap-passphrase p))
 698                 (not (eq tramp-imap-passphrase-cache 'never))
 699                 (y-or-n-p "Keep the passphrase? "))
 700            (setq tramp-imap-passphrase (copy-sequence p))
 701            (setq tramp-imap-passphrase-cache t))
 702
 703          ;; If we still don't have a passphrase, the user didn't want
 704          ;; to keep it.
 705          (when (and
 706                 p
 707                 (not tramp-imap-passphrase))
 708            (setq tramp-imap-passphrase-cache 'never))
 709
 710          p)))))
 711
 712 (defun tramp-imap-encode-buffer ()
 713   (let ((context (epg-make-context 'OpenPGP))
 714         cipher)
 715     (epg-context-set-armor context t)
 716     (epg-context-set-passphrase-callback context
 717                                          #'tramp-imap-passphrase-callback-function)
 718     (epg-context-set-progress-callback context
 719                                        (cons #'epa-progress-callback-function
 720                                              "Encrypting..."))
 721     (message "Encrypting...")
 722     (setq cipher (epg-encrypt-string
 723                   context
 724                   (encode-coding-string (buffer-string) 'utf-8)
 725                   nil))
 726     (message "Encrypting...done")
 727     cipher))
 728
 729 (defun tramp-imap-decode-buffer ()
 730   (let ((context (epg-make-context 'OpenPGP))
 731         plain)
 732     (epg-context-set-passphrase-callback context
 733                                          #'tramp-imap-passphrase-callback-function)
 734     (epg-context-set-progress-callback context
 735                                        (cons #'epa-progress-callback-function
 736                                              "Decrypting..."))
 737     (message "Decrypting...")
 738     (setq plain (decode-coding-string
 739                  (epg-decrypt-string context (buffer-string))
 740                  'utf-8))
 741     (message "Decrypting...done")
 742     plain))
 743
 744 (defun tramp-imap-file-name-mailbox (vec)
 745   (nth 0 (tramp-imap-file-name-parse vec)))
 746
 747 (defun tramp-imap-file-name-name (vec)
 748   (nth 1 (tramp-imap-file-name-parse vec)))
 749
 750 (defun tramp-imap-file-name-localname (vec)
 751   (nth 1 (tramp-imap-file-name-parse vec)))
 752
 753 (defun tramp-imap-file-name-parse (vec)
 754   (let ((name (substring-no-properties (tramp-file-name-localname vec))))
 755     (if (string-match "^/\\([^/]+\\)/?\\(.*\\)$" name)
 756         (list (match-string 1 name)
 757               (match-string 2 name))
 758       nil)))
 759
 760 (defun tramp-imap-make-iht (vec &optional needed-subject)
 761   "Translate the Tramp vector VEC to the imap-hash structure.
 762 With NEEDED-SUBJECT, alters the imap-hash test accordingly."
 763   (let* ((mbox (tramp-imap-file-name-mailbox vec))
 764          (server (tramp-file-name-real-host vec))
 765          (method (tramp-file-name-method vec))
 766          (user (tramp-file-name-user vec))
 767          (ssl (string-equal method tramp-imaps-method))
 768          (port (or (tramp-file-name-port vec)
 769                    (tramp-get-method-parameter method 'tramp-default-port)))
 770          (result (imap-hash-make server port mbox user nil ssl)))
 771     ;; Return the IHT with a test override to look for the subject
 772     ;; marker.
 773     (plist-put
 774      result
 775      :test (format "^%s%s"
 776                    tramp-imap-subject-marker
 777                    (if needed-subject needed-subject "")))))
 778
 779 ;;; TODO:
 780
 781 ;; * Implement `tramp-imap-handle-delete-directory',
 782 ;;   `tramp-imap-handle-make-directory',
 783 ;;   `tramp-imap-handle-make-directory-internal',
 784 ;;   `tramp-imap-handle-set-file-times'.
 785
 786 ;; * Encode the subject.  If the filename has trailing spaces (like
 787 ;;   "test   "), those characters get lost, for example in dired listings.
 788
 789 ;; * When opening a dired buffer, like "/imap::INBOX.test", there are
 790 ;;   several error messages:
 791 ;;   "Buffer has a running process; kill it? (yes or no) "
 792 ;;   "error in process filter: Internal error, tag 6 status BAD code nil text No mailbox selected."
 793 ;;   Afterwards, everything seems to be fine.
 794
 795 ;; * imaps works for local IMAP servers.  Accessing
 796 ;;   "/imaps:imap.gmail.com:/INBOX.test/" results in error
 797 ;;   "error in process filter: Internal error, tag 5 status BAD code nil text UNSELECT not allowed now."
 798
 799 ;; * Improve `tramp-imap-handle-file-attributes' for directories.
 800
 801 ;; * Saving a file creates a second one, instead of overwriting.
 802
 803 ;; * Backup files: just *one* is kept.
 804
 805 ;; * Password requests shall have a descriptive prompt.
 806
 807 ;; * Exiting Emacs, there are running IMAP processes.  Make them quiet
 808 ;;   by `set-process-query-on-exit-flag'.
 809
 810 (provide 'tramp-imap)
 811 ;;; tramp-imap.el ends here
 812
 813 ;; Ignore, for testing only.
 814
 815 ;;; (setq tramp-imap-subject-marker "T")
 816 ;;; (tramp-imap-get-file-entries (tramp-dissect-file-name "/imap:yourhosthere.com:/INBOX.test/4") t)
 817 ;;; (tramp-imap-get-file-entries (tramp-dissect-file-name "/imap:yourhosthere.com:/INBOX.test/") t)
 818 ;;; (tramp-imap-get-file-entries (tramp-dissect-file-name "/imap:yourhosthere.com:/test/4") t)
 819 ;;; (tramp-imap-get-file-entries (tramp-dissect-file-name "/imap:yourhosthere.com:/test/") t)
 820 ;;; (tramp-imap-get-file-entries (tramp-dissect-file-name "/imap:yourhosthere.com:/test/welcommen") t)
 821 ;;; (tramp-imap-get-file-entries (tramp-dissect-file-name "/imap:yourhosthere.com:/test/welcommen") t t)
 822 ;;;(tramp-imap-get-file-inode "/imap:yourhosthere.com:/test/welcome")
 823 ;;; (dired-copy-file "/etc/fstab" "/imap:yourhosthere.com:/test/welcome" t)
 824 ;;; (write-region 1 100 "/imap:yourhosthere.com:/test/welcome")
 825 ;;; (tramp-imap-get-file "/imap:yourhosthere.com:/test/welcome" t)
 826 ;;(with-temp-buffer (insert "hello") (write-file "/imap:yourhosthere.com:/test/welcome"))
 827 ;;(with-temp-buffer (insert "hello") (write-file "/imap:yourhosthere.com:/test/welcome2"))
 828 ;;(file-writable-p "/imap:yourhosthere.com:/test/welcome2")
 829 ;;(file-name-directory "/imap:yourhosthere.com:/test/welcome2")
 830 ;;(with-temp-buffer (insert "hello") (delete-file "/tmp/hellotest") (write-file "/tmp/hellotest") (write-file "/imap:yourhosthere.com:/test/welcome2"))
 831 ;;;(file-exists-p "/imap:yourhosthere.com:/INBOX.test/4")
 832 ;;;(file-attributes "/imap:yourhosthere.com:/INBOX.test/4")
 833 ;;;(setq vec (tramp-dissect-file-name "/imap:yourhosthere.com:/INBOX.test/4"))
 834 ;;;(tramp-imap-handle-file-attributes "/imap:yourhosthere.com:/INBOX.test/4")
 835 ;;; (tramp-imap-handle-insert-file-contents "/imap:user@yourhosthere.com:/INBOX.test/4" nil nil nil nil)
 836 ;;;(insert-file-contents "/imap:yourhosthere.com:/INBOX.test/4")
 837 ;;;(file-attributes "/imap:yourhosthere.com:/test/welcommen")
 838 ;;;(insert-file-contents "/imap:yourhosthere.com:/test/welcome")
 839 ;;;(file-exists-p "/imap:yourhosthere.com:/test/welcome2")
 840 ;;;(tramp-imap-handle-file-attributes "/imap:yourhosthere.com:/test/welcome")
 841 ;;;(tramp-imap-get-file-inode "/imap:yourhosthere.com:/test/welcommen")
 842 ;;;(tramp-imap-get-file-inode "/imap:yourhosthere.com:/test/welcome")
 843 ;;;(file-writable-p "/imap:yourhosthere.com:/test/welcome2")
 844 ;;; (delete-file "/imap:yourhosthere.com:/test/welcome")
 845 ;;; (tramp-imap-get-file "/imap:yourhosthere.com:/test/welcommen" t)
 846 ;;; (tramp-imap-get-file "/imap:yourhosthere.com:/test/welcome" t)
 847 ;;;(tramp-imap-file-name-mailbox (tramp-dissect-file-name "/imap:yourhosthere.com:/INBOX.test"))
 848 ;;;(tramp-imap-file-name-mailbox (tramp-dissect-file-name "/imap:yourhosthere.com:/INBOX.test/new/old"))
 849 ;;;(tramp-imap-file-name-mailbox (tramp-dissect-file-name "/imap:yourhosthere.com:/INBOX.test/new"))
 850 ;;;(tramp-imap-file-name-parse (tramp-dissect-file-name "/imap:yourhosthere.com:/INBOX.test/new/two"))
 851 ;;;(tramp-imap-file-name-parse (tramp-dissect-file-name "/imap:yourhosthere.com:/INBOX.test/new/one"))
 852 ;;;(tramp-imap-file-name-parse (tramp-dissect-file-name "/imap:yourhosthere.com:/INBOX.test"))
 853 ;;; (tramp-imap-file-name-parse (tramp-dissect-file-name "/imap:yourhosthere.com:/test/4"))
 854 ;;; (tramp-imap-file-name-parse (tramp-dissect-file-name "/imap:yourhosthere.com:/test/"))
 855 ;;; (tramp-imap-file-name-parse (tramp-dissect-file-name "/imap:yourhosthere.com:/test/welcommen"))
 856 ;;; (tramp-imap-file-name-parse (tramp-dissect-file-name "/imap:yourhosthere.com:/test/welcommen"))
 857 ;;; (tramp-imap-make-iht (tramp-dissect-file-name "/imap:yourhosthere.com:/test/welcommen"))
 858 ;;; (tramp-imap-make-iht (tramp-dissect-file-name "/imap:yourhosthere.com:/INBOX.test/4"))
 859 ;;; (tramp-imap-make-iht (tramp-dissect-file-name "/imap:yourhosthere.com:/INBOX.test/4") "extra")
 860
 861 ;; arch-tag: f2723749-58fb-4f29-894e-39708096e850