elmo/elmo-net.el

   1 ;;; elmo-net.el --- Network module for ELMO.
   2
   3 ;; Copyright (C) 1998,1999,2000 Yuuichi Teranishi <teranisi@gohome.org>
   4
   5 ;; Author: Yuuichi Teranishi <teranisi@gohome.org>
   6 ;; Keywords: mail, net news
   7
   8 ;; This file is part of ELMO (Elisp Library for Message Orchestration).
   9
  10 ;; This program 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 2, or (at your option)
  13 ;; any later version.
  14 ;;
  15 ;; This program 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; see the file COPYING.  If not, write to the
  22 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  23 ;; Boston, MA 02111-1307, USA.
  24 ;;
  25
  26 ;;; Commentary:
  27 ;;
  28
  29 (eval-when-compile (require 'cl))
  30
  31 (require 'elmo-util)
  32 (require 'elmo-dop)
  33 (require 'elmo-vars)
  34 (require 'elmo-cache)
  35 (require 'elmo)
  36
  37 ;;; Code:
  38 ;;
  39
  40 (defconst elmo-net-folder-name-syntax '((?@ [server ".+"])
  41                                         (?: [port "^[0-9]+$"])
  42                                         (?! stream-type)))
  43
  44 ;;; ELMO net folder
  45 (eval-and-compile
  46   (luna-define-class elmo-net-folder
  47                      (elmo-folder)
  48                      (user auth server port stream-type))
  49   (luna-define-internal-accessors 'elmo-net-folder))
  50
  51 ;;; Session
  52 (eval-and-compile
  53   (autoload 'starttls-negotiate "starttls")
  54   (autoload 'sasl-find-mechanism "sasl")
  55   (autoload 'sasl-make-client "sasl")
  56   (autoload 'sasl-mechanism-name "sasl")
  57   (autoload 'sasl-next-step "sasl")
  58   (autoload 'sasl-step-data "sasl")
  59   (autoload 'sasl-step-set-data "sasl"))
  60
  61 (defvar sasl-mechanisms)
  62
  63 (defcustom elmo-network-session-idle-timeout nil
  64   "Idle timeout of the network cache. Specified in seconds.
  65 If elapsed time since last access is larger than this value,
  66 cached session is not reused.
  67 If nil, network cache is reused."
  68   :type '(choice number (const nil))
  69   :group 'elmo)
  70
  71 ;;; Code:
  72 ;;
  73 (eval-and-compile
  74   (luna-define-class elmo-network-session () (name
  75                                               server
  76                                               port
  77                                               user
  78                                               auth
  79                                               stream-type
  80                                               process
  81                                               greeting
  82                                               last-accessed))
  83   (luna-define-internal-accessors 'elmo-network-session))
  84
  85 (luna-define-generic elmo-network-initialize-session (session)
  86   "Initialize SESSION (Called before authentication).")
  87
  88 (luna-define-generic elmo-network-initialize-session-buffer (session buffer)
  89   "Initialize SESSION's BUFFER.")
  90
  91 (luna-define-generic elmo-network-authenticate-session (session)
  92   "Authenticate SESSION.")
  93
  94 (luna-define-generic elmo-network-setup-session (session)
  95   "Setup SESSION. (Called after authentication).")
  96
  97 (luna-define-generic elmo-network-close-session (session)
  98   "Close SESSION.")
  99
 100 (luna-define-method
 101   elmo-network-initialize-session-buffer ((session
 102                                            elmo-network-session) buffer)
 103   (with-current-buffer buffer
 104     (set-buffer-multibyte nil)
 105     (buffer-disable-undo (current-buffer))))
 106
 107 (luna-define-method elmo-network-close-session ((session elmo-network-session))
 108   (when (elmo-network-session-process-internal session)
 109 ;;; (memq (process-status (elmo-network-session-process-internal session))
 110 ;;;       '(open run))
 111     (kill-buffer (process-buffer
 112                   (elmo-network-session-process-internal session)))
 113     (delete-process (elmo-network-session-process-internal session))))
 114
 115 (defmacro elmo-network-stream-type-spec-string (stream-type)
 116   (` (nth 0 (, stream-type))))
 117
 118 (defmacro elmo-network-stream-type-symbol (stream-type)
 119   (` (nth 1 (, stream-type))))
 120
 121 (defmacro elmo-network-stream-type-feature (stream-type)
 122   (` (nth 2 (, stream-type))))
 123
 124 (defmacro elmo-network-stream-type-function (stream-type)
 125   (` (nth 3 (, stream-type))))
 126
 127 (defsubst elmo-network-session-password-key (session)
 128   (format "%s:%s/%s@%s:%d"
 129           (upcase
 130            (nth 1 (split-string (symbol-name
 131                                  (luna-class-name session)) "[4-]")))
 132           (elmo-network-session-user-internal session)
 133           (elmo-network-session-auth-internal session)
 134           (elmo-network-session-server-internal session)
 135           (elmo-network-session-port-internal session)))
 136
 137 (defvar elmo-network-session-cache nil)
 138
 139 (defsubst elmo-network-session-cache-key (name folder)
 140   "Returns session cache key for NAME and FOLDER."
 141   (format "%s:%s/%s@%s:%d%s"
 142           name
 143           (elmo-net-folder-user-internal folder)
 144           (elmo-net-folder-auth-internal folder)
 145           (elmo-net-folder-server-internal folder)
 146           (elmo-net-folder-port-internal folder)
 147           (or
 148            (elmo-network-stream-type-spec-string
 149             (elmo-net-folder-stream-type-internal folder)) "")))
 150
 151 (defun elmo-network-clear-session-cache ()
 152   "Clear session cache."
 153   (interactive)
 154   (dolist (pair elmo-network-session-cache)
 155     (elmo-network-close-session (cdr pair)))
 156   (setq elmo-network-session-cache nil))
 157
 158 (defmacro elmo-network-session-buffer (session)
 159   "Get buffer for SESSION."
 160   (` (process-buffer (elmo-network-session-process-internal
 161                       (, session)))))
 162
 163 (defun elmo-network-get-session (class name folder &optional if-exists)
 164   "Get network session from session cache or a new network session.
 165 CLASS is the class name of the session.
 166 NAME is the name of the process.
 167 FOLDER is the ELMO folder structure.
 168 Returns a `elmo-network-session' instance.
 169 If optional argument IF-EXISTS is non-nil, it does not return session
 170 if there is no session cache.
 171 if making session failed, returns nil."
 172   (let (pair session key)
 173     (if (not (elmo-plugged-p
 174               (elmo-net-folder-server-internal folder)
 175               (elmo-net-folder-port-internal folder)
 176               (elmo-network-stream-type-symbol
 177                (elmo-net-folder-stream-type-internal folder))))
 178         (error "Unplugged"))
 179     (setq pair (assoc (setq key (elmo-network-session-cache-key name folder))
 180                       elmo-network-session-cache))
 181     (when (and pair
 182                (or (not (memq (process-status
 183                                (elmo-network-session-process-internal
 184                                 (cdr pair)))
 185                               '(open run)))
 186                    (and elmo-network-session-idle-timeout
 187                         (elmo-network-session-last-accessed-internal
 188                          (cdr pair))
 189                         (elmo-time-expire
 190                          (elmo-network-session-last-accessed-internal
 191                           (cdr pair))
 192                          elmo-network-session-idle-timeout))))
 193       (setq elmo-network-session-cache
 194             (delq pair elmo-network-session-cache))
 195       (elmo-network-close-session (cdr pair))
 196       (setq pair nil))
 197     (if pair
 198         (progn
 199           (elmo-network-session-set-last-accessed-internal
 200            (cdr pair) (current-time))
 201           (cdr pair))                   ; connection cache exists.
 202       (unless if-exists
 203         (setq session
 204               (elmo-network-open-session
 205                class
 206                name
 207                (elmo-net-folder-server-internal folder)
 208                (elmo-net-folder-port-internal folder)
 209                (elmo-net-folder-user-internal folder)
 210                (elmo-net-folder-auth-internal folder)
 211                (elmo-net-folder-stream-type-internal folder)))
 212         (setq elmo-network-session-cache
 213               (cons (cons key session)
 214                     elmo-network-session-cache))
 215         session))))
 216
 217 (defun elmo-network-open-session (class name server port user auth
 218                                         stream-type)
 219   "Open an authenticated network session.
 220 CLASS is the class name of the session.
 221 NAME is the name of the process.
 222 SERVER is the name of the server server.
 223 PORT is the port number of the service.
 224 USER is the user-id for the authenticate.
 225 AUTH is the authenticate method name (symbol).
 226 STREAM-TYPE is the stream type (See also `elmo-network-stream-type-alist').
 227 Returns a process object.  if making session failed, returns nil."
 228   (let ((session
 229          (luna-make-entity class
 230                            :name name
 231                            :server server
 232                            :port port
 233                            :user user
 234                            :auth auth
 235                            :stream-type stream-type
 236                            :process nil
 237                            :greeting nil
 238                            :last-accessed (current-time)
 239                            ))
 240         (buffer (format " *%s session for %s@%s:%d%s"
 241                         name
 242                         user
 243                         server
 244                         port
 245                         (or (elmo-network-stream-type-spec-string stream-type)
 246                             "")))
 247         process)
 248     (condition-case error
 249         (progn
 250           (if (get-buffer buffer) (kill-buffer buffer))
 251           (setq buffer (get-buffer-create buffer))
 252           (elmo-network-initialize-session-buffer session buffer)
 253           (elmo-network-session-set-process-internal
 254            session
 255            (setq process (elmo-open-network-stream
 256                           (elmo-network-session-name-internal session)
 257                           buffer server port stream-type)))
 258           (when process
 259             (elmo-network-initialize-session session)
 260             (elmo-network-authenticate-session session)
 261             (elmo-network-setup-session session)))
 262       (error
 263        (when (eq (car error) 'elmo-open-error)
 264          (elmo-set-plugged nil server port
 265                            (elmo-network-stream-type-symbol stream-type)
 266                            (current-time))
 267          (message "Auto plugged off at %s:%d :%s" server port (cadr error))
 268          (sit-for 1))
 269        (when (eq (car error) 'elmo-authenticate-error)
 270          (elmo-remove-passwd (elmo-network-session-password-key session)))
 271        (elmo-network-close-session session)
 272        (signal (car error)(cdr error))))
 273     session))
 274
 275 (defun elmo-open-network-stream (name buffer server service stream-type)
 276   (let ((auto-plugged (and elmo-auto-change-plugged
 277                            (> elmo-auto-change-plugged 0)))
 278         process)
 279     (if (and stream-type
 280              (elmo-network-stream-type-feature stream-type))
 281         (require (elmo-network-stream-type-feature stream-type)))
 282     (condition-case err
 283         (let (process-connection-type)
 284           (as-binary-process
 285            (setq process
 286                  (if stream-type
 287                      (funcall (elmo-network-stream-type-function stream-type)
 288                               name buffer server service)
 289                    (open-network-stream name buffer server service)))))
 290       (error
 291        (when auto-plugged
 292          (elmo-set-plugged nil server service
 293                            (elmo-network-stream-type-symbol stream-type)
 294                            (current-time))
 295          (message "Auto plugged off at %s:%d" server service)
 296          (sit-for 1))
 297        (signal (car err) (cdr err))))
 298     (when process
 299       (process-kill-without-query process)
 300       (when auto-plugged
 301         (elmo-set-plugged t server service
 302                           (elmo-network-stream-type-symbol stream-type)))
 303       process)))
 304
 305 (defun elmo-get-network-stream-type (symbol)
 306   "Return network stream type corresponding to SYMBOL.
 307 Returned value is searched from `elmo-network-stream-type-alist'."
 308   (let ((alist elmo-network-stream-type-alist)
 309         spec)
 310     (while alist
 311       (when (eq (nth 1 (car alist)) symbol)
 312         (setq spec (car alist))
 313         (setq alist nil))
 314       (setq alist (cdr alist)))
 315     spec))
 316
 317 (defconst elmo-net-quote-chars "@:!")
 318
 319 (defun elmo-net-format-quoted (string &optional extra-chars)
 320   (if (string-match (concat "[" elmo-net-quote-chars extra-chars "]")
 321                     string)
 322       (elmo-quoted-token string)
 323     string))
 324
 325 (defun elmo-net-folder-set-parameters (folder tokens &optional defaults)
 326   (let ((port (cdr (assq 'port tokens)))
 327         (stream-type (cdr (assq 'stream-type tokens))))
 328     ;; server
 329     (elmo-net-folder-set-server-internal
 330      folder
 331      (or (cdr (assq 'server tokens))
 332          (plist-get defaults :server)))
 333     ;; port
 334     (elmo-net-folder-set-port-internal
 335      folder
 336      (or (and port (string-to-int port))
 337          (plist-get defaults :port)))
 338     ;; stream-type
 339     (elmo-net-folder-set-stream-type-internal
 340      folder
 341      (or (and stream-type (assoc (concat "!" stream-type)
 342                                  elmo-network-stream-type-alist))
 343          (plist-get defaults :stream-type)))))
 344
 345 (luna-define-method elmo-folder-initialize ((folder elmo-net-folder) name)
 346   ;; user and auth should be set in subclass.
 347   (when (string-match "\\(@[^@:/!]+\\)?\\(:[0-9]+\\)?\\(!.*\\)?$" name)
 348     (elmo-net-folder-set-parameters
 349      folder
 350      (car (elmo-parse-separated-tokens
 351            (substring name (match-beginning 0))
 352            elmo-net-folder-name-syntax))))
 353   folder)
 354
 355 (luna-define-method elmo-net-port-info ((folder elmo-net-folder))
 356   (list (elmo-net-folder-server-internal folder)
 357         (elmo-net-folder-port-internal folder)
 358         (elmo-network-stream-type-symbol
 359          (elmo-net-folder-stream-type-internal folder))))
 360
 361 (defun elmo-net-port-label (folder)
 362   (concat
 363    (symbol-name (elmo-folder-type-internal folder))
 364    (if (elmo-net-folder-stream-type-internal folder)
 365        (concat "!" (symbol-name
 366                     (elmo-network-stream-type-symbol
 367                      (elmo-net-folder-stream-type-internal
 368                       folder)))))))
 369
 370 (luna-define-method elmo-folder-plugged-p ((folder elmo-net-folder))
 371   (apply 'elmo-plugged-p
 372          (append (elmo-net-port-info folder)
 373                  (list nil (quote (elmo-net-port-label folder))))))
 374
 375 (luna-define-method elmo-folder-set-plugged ((folder elmo-net-folder)
 376                                              plugged &optional add)
 377   (apply 'elmo-set-plugged plugged
 378          (append (elmo-net-port-info folder)
 379                  (list nil nil (quote (elmo-net-port-label folder)) add))))
 380
 381 (luna-define-method elmo-folder-create ((folder elmo-net-folder))
 382   (if (elmo-folder-plugged-p folder)
 383       (elmo-folder-send folder 'elmo-folder-create-plugged)
 384     (elmo-folder-send folder 'elmo-folder-create-unplugged)))
 385
 386 (luna-define-method elmo-folder-create-unplugged ((folder elmo-net-folder))
 387   (if elmo-enable-disconnected-operation
 388       (elmo-folder-create-dop folder)
 389     (error "Unplugged")))
 390
 391 (luna-define-method elmo-folder-exists-p ((folder elmo-net-folder))
 392   (if (elmo-folder-plugged-p folder)
 393       (elmo-folder-send folder 'elmo-folder-exists-p-plugged)
 394     ;; If unplugged, guess by msgdb.
 395     (file-directory-p (elmo-folder-msgdb-path folder))))
 396
 397 (luna-define-method elmo-folder-status ((folder elmo-net-folder))
 398   (if (elmo-folder-plugged-p folder)
 399       (elmo-folder-send folder 'elmo-folder-status-plugged)
 400     (elmo-folder-send folder 'elmo-folder-status-unplugged)))
 401
 402 (luna-define-method elmo-folder-status-unplugged
 403   ((folder elmo-net-folder))
 404   (if elmo-enable-disconnected-operation
 405       (elmo-folder-status-dop folder)
 406     (error "Unplugged")))
 407
 408 (luna-define-method elmo-folder-next-message-number ((folder elmo-net-folder))
 409   (if (elmo-folder-plugged-p folder)
 410       (elmo-folder-send folder 'elmo-folder-next-message-number-plugged)
 411     (elmo-folder-send folder 'elmo-folder-next-message-number-unplugged)))
 412
 413 (luna-define-method elmo-folder-next-message-number-unplugged
 414   ((folder elmo-net-folder))
 415   (if elmo-enable-disconnected-operation
 416       (elmo-folder-next-message-number-dop folder)
 417     (error "Unplugged")))
 418
 419 (luna-define-method elmo-folder-list-messages-internal
 420   ((folder elmo-net-folder) &optional nohide)
 421   (elmo-net-folder-list-messages-internal folder nohide))
 422
 423 (defun elmo-net-folder-list-messages-internal (folder nohide)
 424   (if (elmo-folder-plugged-p folder)
 425       (elmo-folder-send folder 'elmo-folder-list-messages-plugged nohide)
 426     (elmo-folder-send folder 'elmo-folder-list-messages-unplugged)))
 427
 428 (luna-define-method elmo-folder-list-messages-plugged
 429   ((folder elmo-net-folder))
 430   nil)
 431
 432 ;; Should consider offline append and removal.
 433 (luna-define-method elmo-folder-list-messages-unplugged ((folder
 434                                                           elmo-net-folder))
 435   (if elmo-enable-disconnected-operation
 436       (let ((deleting (elmo-dop-list-deleting-messages folder)))
 437         (nconc
 438          ;; delete deleting messages
 439          (elmo-delete-if
 440           (lambda (number) (memq number deleting))
 441           ;; current number-list.
 442           (elmo-folder-list-messages folder nil 'in-msgdb))
 443          ;; append appending messages
 444          (mapcar (lambda (x) (* -1 x))
 445                  (elmo-dop-spool-folder-list-messages folder))))
 446     t))
 447
 448 (luna-define-method elmo-folder-list-flagged-internal ((folder elmo-net-folder)
 449                                                        flag)
 450   (if (and (elmo-folder-plugged-p folder)
 451            (elmo-folder-use-flag-p folder))
 452       (elmo-folder-send folder 'elmo-folder-list-flagged-plugged flag)
 453     ;; Should consider offline append and removal?
 454     t))
 455
 456 (luna-define-method elmo-folder-list-flagged-plugged ((folder elmo-net-folder)
 457                                                       flag)
 458   t)
 459
 460 (luna-define-method elmo-folder-delete-messages-internal ((folder
 461                                                            elmo-net-folder)
 462                                                           numbers)
 463    (if (elmo-folder-plugged-p folder)
 464        (elmo-folder-send folder 'elmo-folder-delete-messages-plugged numbers)
 465      (elmo-folder-send folder 'elmo-folder-delete-messages-unplugged numbers)))
 466
 467 (luna-define-method elmo-folder-delete-messages-unplugged ((folder
 468                                                             elmo-net-folder)
 469                                                            numbers)
 470   (elmo-folder-delete-messages-dop folder numbers))
 471
 472 (luna-define-method elmo-folder-msgdb-create ((folder elmo-net-folder)
 473                                               numbers flag-table)
 474   (if (elmo-folder-plugged-p folder)
 475       (elmo-folder-send folder 'elmo-folder-msgdb-create-plugged
 476                         numbers flag-table)
 477     (elmo-folder-send folder 'elmo-folder-msgdb-create-unplugged
 478                       numbers flag-table)))
 479
 480 (luna-define-method elmo-folder-msgdb-create-unplugged ((folder
 481                                                          elmo-net-folder)
 482                                                         numbers
 483                                                         flag-table)
 484   ;; XXXX should be appended to already existing msgdb.
 485   (elmo-dop-msgdb
 486    (elmo-folder-msgdb-create (elmo-dop-spool-folder folder)
 487                              (mapcar 'abs numbers)
 488                              flag-table)))
 489
 490 (luna-define-method elmo-folder-set-flag :before ((folder elmo-net-folder)
 491                                                   numbers
 492                                                   flag
 493                                                   &optional is-local)
 494   (when (and (not is-local)
 495              (elmo-folder-use-flag-p folder))
 496     (elmo-folder-send folder
 497                       (if (elmo-folder-plugged-p folder)
 498                           'elmo-folder-set-flag-plugged
 499                         'elmo-folder-set-flag-unplugged)
 500                       numbers
 501                       flag)))
 502
 503 (luna-define-method elmo-folder-unset-flag :before ((folder elmo-net-folder)
 504                                                     numbers
 505                                                     flag
 506                                                     &optional is-local)
 507   (when (and (not is-local)
 508              (elmo-folder-use-flag-p folder))
 509     (elmo-folder-send folder
 510                       (if (elmo-folder-plugged-p folder)
 511                           'elmo-folder-unset-flag-plugged
 512                         'elmo-folder-unset-flag-unplugged)
 513                       numbers
 514                       flag)))
 515
 516 (luna-define-method elmo-folder-set-flag-unplugged ((folder elmo-net-folder)
 517                                                     numbers flag)
 518   (elmo-folder-set-flag-dop folder numbers flag))
 519
 520 (luna-define-method elmo-folder-unset-flag-unplugged ((folder elmo-net-folder)
 521                                                       numbers flag)
 522   (elmo-folder-unset-flag-dop folder numbers flag))
 523
 524 (luna-define-method elmo-message-encache :around ((folder elmo-net-folder)
 525                                                   number &optional read)
 526   (if (elmo-folder-plugged-p folder)
 527       (luna-call-next-method)
 528     (if elmo-enable-disconnected-operation
 529         (elmo-message-encache-dop folder number read)
 530       (error "Unplugged"))))
 531
 532 (luna-define-generic elmo-message-fetch-plugged (folder number strategy
 533                                                         &optional
 534                                                         section
 535                                                         outbuf
 536                                                         unseen)
 537   "")
 538
 539 (luna-define-generic elmo-message-fetch-unplugged (folder number strategy
 540                                                           &optional
 541                                                           section
 542                                                           outbuf
 543                                                           unseen)
 544   "")
 545
 546 (luna-define-method elmo-message-fetch-internal ((folder elmo-net-folder)
 547                                                  number strategy
 548                                                  &optional section unseen)
 549   (if (elmo-folder-plugged-p folder)
 550       (elmo-message-fetch-plugged folder number
 551                                   strategy section
 552                                   (current-buffer) unseen)
 553     (elmo-message-fetch-unplugged folder number
 554                                   strategy section
 555                                   (current-buffer) unseen)))
 556
 557 (luna-define-method elmo-message-fetch-unplugged
 558   ((folder elmo-net-folder) number strategy  &optional section outbuf unseen)
 559   (if (and elmo-enable-disconnected-operation
 560            (< number 0))
 561       (elmo-message-fetch-internal
 562        (elmo-dop-spool-folder folder) (abs number) strategy
 563        section unseen)
 564     (error "Unplugged")))
 565
 566 (luna-define-method elmo-folder-check ((folder elmo-net-folder))
 567   (if (elmo-folder-plugged-p folder)
 568       (elmo-folder-send folder 'elmo-folder-check-plugged)))
 569
 570 (luna-define-method elmo-folder-close :after ((folder elmo-net-folder))
 571   (if (elmo-folder-plugged-p folder)
 572       (elmo-folder-send folder 'elmo-folder-check-plugged)))
 573
 574 (luna-define-method elmo-folder-diff :around ((folder elmo-net-folder))
 575   (if (and (elmo-folder-use-flag-p folder)
 576            (elmo-folder-plugged-p folder))
 577       (elmo-folder-send folder 'elmo-folder-diff-plugged)
 578     (luna-call-next-method)))
 579
 580 (luna-define-method elmo-folder-local-p ((folder elmo-net-folder))
 581   nil)
 582
 583 (luna-define-method elmo-quit ((folder elmo-net-folder))
 584   (elmo-network-clear-session-cache))
 585
 586 (require 'product)
 587 (product-provide (provide 'elmo-net) (require 'elmo-version))
 588
 589 ;;; elmo-net.el ends here