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