;;; cmail-pop3glue.el --- cmail interface to cmail-gnuspop3.el library

;; Author: Takeshi Morishima (tm@interaccess.com)
;; Keywords: mail
;; Created at: Sat Feb 26 15:39:56 JST 2000

;; This file is part of cmail (a mail utility for GNU Emacs)

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

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

;; You should have received a copy of the GNU General Public License
;; along with this program; see the file COPYING.  If not, write to
;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.

;;; Commentary:

;; This is a cmail option feature module, to be used for interfacing
;; to Gnus/pop3.el.
;;
;; It supports:
;;
;; 1. basic message retrieval using pop3 and apop protocols
;;
;; 2. polling server check and status display to the mode line in
;;    conjunction with display-time mode.
;;
;; What's special with this option module?
;;
;; Because pop3.el is entirely written in lisp, it was possible to add
;; finer control in the protocol procedure, such as detailed status
;; feedback and better exception handling. For example, this
;; implements the following special features.
;;
;; 1. Displays message count and total number of messages on the
;;    server while retrieving messages.
;;
;; 2. When polling the POP servers for message arrival check, it will
;;    gather information as much as possible, which would be helpful
;;    for the users. Such info includes the on-line status, error
;;    status ans actual number of messages waiting for retrieval.
;;
;; 3. It can distinguish error case due to server unavailability
;;    versus error due to authentication failure. It makes trouble
;;    shooting easier for typical connection problem.
;;
;; Wish list
;;
;; 1. Off-line mode integration.
;;
;; 2. Link speed measurement per server connection, and control
;;    message retrieval based on user definition of low bandwidth
;;    link. (For example, do not fetch a long message when connected
;;    through modem.)
;;
;; 4. It can add the source server and account info to each message
;;    header using X-cmail-delivered-from: header field.
;;
;; 5. Auto connection timeout adjustment based on customizable tuning
;;    parameters and actual measurement.  The time measurement is
;;    taken whenever server gets connected. Then necessary adjustment
;;    will be automatically made for the next connect attempt.
;;
;; 6. Server messages can be purged after specified time is elapsed.
;;    (The POP connection is closed and reopened again.) This may be
;;    helpful in a network environment in which TCP connections are
;;    often dropped. e.g wireless packet network. Even if POP
;;    connection is disconnected in the middle of retrieval,
;;    re-downloading would occur only for the duration of this timer
;;    (plus time needed for the last message whose transmission was
;;    interrupted in the middle).
;;

;;; Code:

(require 'cmail-gnuspop3)
(require 'timer)

(defvar *cmail-pop3glue-semaphore nil)
(defvar *cmail-pop3glue-check-count 0)
(defvar *cmail-pop3glue-disp-info-cache nil)

(defun cmail-pop3glue-movemail (crash-box proto-spec)
  (unwind-protect
      (let ((server (elt proto-spec 1))
	    (logname (elt proto-spec 2))
	    (password (elt proto-spec 3))
	    (options (elt proto-spec 4))
	    maildrop apop res apop-p leave-p)
	(setq *cmail-pop3glue-semaphore t)
	(catch 'version-compat
	  ;; obtain the account info
	  (if (null password)
	      (setq password (cmail-lookup-password 'pop3 server logname)))
	  (if (or (null password) (string= password ""))
	      (progn
		(setq password (cmail-prompt-for-password server logname))
		(cmail-save-password 'pop3 server logname password)))
	  ;; parse options and make sure version is compatible with the option.
	  (if (string-match "\\`-.*A.*\\'" options)
	      (setq apop-p t))
	  (if (string-match "\\`-.*k.*\\'" options)
	      (setq leave-p t))
	  ;; fetch messages now
	  (if (and (stringp password) (not (string= password "")))
	      (progn
		(cmail-message-resource1 'get-spooled-mail-5 server)
		(setq res (cmail-pop3glue-fetch
			   crash-box logname server password apop-p leave-p))
		(cond ((eq res 'auth-failure)
		       (cmail-save-password 'pop3 server logname "")
		       (message "POP3: Auth failure. Password cache flushed.")
		       (sit-for 1))
		      ((eq res 'cannot-open)
		       (message "POP3: Cannot open POP connection.")
		       (sit-for 1))
		      ((eq res 'connection-timeout)
		       (message "POP3: Connection timeout.")
		       (sit-for 1))
		      (t (cmail-message-resource1 'get-spooled-mail-6 server))
		      )))))
    (setq *cmail-pop3glue-semaphore nil)))
  
(defvar *pop3glue-port 110)
(defun cmail-pop3glue-fetch (crash-box
			     logname server password
			     &optional apop-p leave-p)
  ;; TODO: cmail-pop3glue-commit-interval support
  (let (process open-start open-time message-count)
    ;; catch error cases
    (catch 'error-exit
      ;; open the session.
      (condition-case nil
	  ;; TODO: with NT it does not seem to work when looking up DNS.
	  (with-timeout ((cmail-pop3glue-get-open-timeout server)
			 (throw 'error-exit 'connection-timeout))
	    (setq process (cmail-gnuspop3-open-server server *pop3glue-port)))
	(error (throw 'error-exit 'cannot-open)))
      ;; user authentication
      (condition-case nil
	  (let ((cmail-gnuspop3-password password))
	    (if apop-p
		(cmail-gnuspop3-apop process logname)
	      (cmail-gnuspop3-user process logname)
	      (cmail-gnuspop3-pass process))
	    (if (not (= (process-exit-status process) 0))
		(throw 'error-exit 'auth-failure)))
	(error (throw 'error-exit 'auth-failure)))
      (setq message-count (cmail-pop3glue-fetch1
			   crash-box process server leave-p))
      (if (and (numberp message-count) (not (= message-count 0)))
	  (progn
	    (cmail-pop3glue-set-account-status server logname 0)
	    (setq *cmail-pop3glue-check-count 0)
	    (setq *cmail-pop3glue-disp-info-cache nil)
	    (run-hooks 'rmail-after-get-new-mail-hook)))
      t)))

(defun cmail-pop3glue-fetch1 (crash-box process server leave-p)
  (let ((cmail-gnuspop3-leave-mail-on-server leave-p)
	(cmail-gnuspop3-uidl-file-name
	 (convert-standard-filename
	  (concat cmail-gnuspop3-uidl-file-name "-" server)))
	(cmail-gnuspop3-uidl-support 'dont-know)
	(retrieved-messages nil)
	messages message-count retr-buf start (n 1))
    ;; get messages that are suitable for download
    (message "Retrieving message list...")
    (setq messages (cmail-gnuspop3-get-message-numbers process))
    (setq message-count (length (cdr messages)))
    (message "Retrieving message list...%d of %d unread"
	     message-count (car messages))
    (setq messages (cdr messages))
    ;; setup retrieval buffer
    (setq retr-buf (get-buffer-create " *cmail-gnuspop3-retr*"))
    (with-current-buffer retr-buf
      (delete-region (point-min) (point-max))
      (setq start (point)))
    (unwind-protect
	(progn
	  (while messages
	    (message (format
		      "Retrieving message %d of %d (%d octets) from %s..."
		      n message-count (cdar messages) server))
	    (cmail-gnuspop3-retr process (caar messages) retr-buf)
	    (with-current-buffer retr-buf
	      (goto-char start)
	      (while (looking-at "^[ \t]*\n") (replace-match ""))
	      (insert "\001\001\001\001\n")
	      ;; hack: delete From delimiter if exists.
	      (if (looking-at "^From .*\n") (replace-match ""))
	      (goto-char (point-max))
	      (if (not (bolp)) (insert "\n"))
	      (insert "\n")
	      (setq start (point)))
	    (setq retrieved-messages
		  (cons (caar messages) retrieved-messages))
	    (setq messages (cdr messages))
	    (setq n (1+ n)))
	  (with-current-buffer retr-buf
	    (write-region-as-binary (point-min) (point-max)
				    crash-box 'append 'nomesg))
	  (if leave-p (cmail-gnuspop3-save-uidls)
	    ;; now delete the messages we have retrieved
	    (while retrieved-messages
	      (message "Deleting message %d of %d from %s..."
		       (car retrieved-messages) message-count server)
	      (cmail-gnuspop3-dele process (car retrieved-messages))
	      (setq retrieved-messages (cdr retrieved-messages)))))
      (cmail-gnuspop3-quit process)
      (kill-buffer retr-buf))
    message-count))


;; TODO: time measrurement
(defun cmail-pop3glue-get-open-timeout (server) 60)

;; periodic POP message arrival check
;;
(defun cmail-pop3glue-display-hook ()
  ;; always display current status
  (let ((prefix-string display-time-string))
    (cmail-pop3glue-add-display-info prefix-string)
    ;; decide if we are going to update the status
    (if *cmail-pop3glue-semaphore
	;; skip checking to not disturb the main message retrieval
	nil
      (unwind-protect
	  (progn
	    (setq *cmail-pop3glue-semaphore t)
	    (setq *cmail-pop3glue-check-count (1+ *cmail-pop3glue-check-count))
	    (if (= 0 (% *cmail-pop3glue-check-count
			(if (< cmail-gnuspop3-biff-icount 1) 1
			  cmail-gnuspop3-biff-icount)))
		(progn
		  ;; update the status and update the display
		  (setq *cmail-pop3glue-disp-info-cache nil)
		  (cmail-pop3glue-peek-at-servers)
		  (cmail-pop3glue-add-display-info prefix-string))))
	(setq *cmail-pop3glue-semaphore nil)))))

(defun cmail-pop3glue-peek-at-servers ()
  (let ((spec-list (cmail-normalize-account-info)))
    (while spec-list
      (if (eq 'pop3 (car (car spec-list)))
	  (cmail-pop3glue-retrieve-count (car spec-list)))
      (setq spec-list (cdr spec-list)))))

(defun cmail-pop3glue-retrieve-count (proto-spec)
  (let ((server (elt proto-spec 1))
	(logname (elt proto-spec 2))
	(password (elt proto-spec 3))
	(options (elt proto-spec 4))
	apop res apop-p)
    (if (null password)
	(setq password (cmail-lookup-password 'pop3 server logname)))
    (if (string-match "\\`-.*A.*\\'" options)
	(setq apop-p t))
    (if (and (stringp password) (not (string= password "")))
	(let (process message-count)
	  ;; catch error cases
	  (catch 'error-exit
	    ;; open the session.
	    (condition-case nil
		(with-timeout ((cmail-pop3glue-get-open-timeout server)
			       (cmail-pop3glue-set-account-status
				server logname 'connection-timeout)
			       (throw 'error-exit 0))
		  (setq process (cmail-gnuspop3-open-server server *pop3glue-port)))
	      (error (cmail-pop3glue-set-account-status
		      server logname 'cannot-open)
		     (throw 'error-exit nil)))
	    ;; user authentication
	    (condition-case nil
		(let ((cmail-gnuspop3-password password))
		  (if apop-p
		      (cmail-gnuspop3-apop process logname)
		    (cmail-gnuspop3-user process logname)
		    (cmail-gnuspop3-pass process))
		  (if (not (= (process-exit-status process) 0))
		      (progn
			(cmail-pop3glue-set-account-status
			 server logname 'auth-failure)
			(throw 'error-exit nil))))
	      (error (cmail-pop3glue-set-account-status
		      server logname 'auth-failure)
		     (throw 'error-exit nil)))
	    (setq message-count (car (cmail-gnuspop3-stat process)))
	    (cmail-gnuspop3-quit process)
	    (if (integerp message-count)
		(cmail-pop3glue-set-account-status
		 server logname message-count))
	    t))
      (cmail-pop3glue-set-account-status server logname 'auth-failure))))

;; Status display
;; Mail(*) no accounts being checked
;; Mail(-) completely offline
;; Mail(!) all account error on account authentication
;; Mail(0) on-line, no message pending
;; Mail(3) on-line, totoal 3 message pending
;; Mail(4-) total 4 message pending, but some accounts off-line
;; Mail(4!) total 4 message pending, but some accounts auth failure
;; Mail(5!-) total 5 message pending, but some accounts auth failure,
;;           other accounts off-line
(defun cmail-pop3glue-add-display-info (prefix-string)
  (let (status-list (total-count 0) any-success-p tmp-list status-string)
    (if (stringp *cmail-pop3glue-disp-info-cache)
	(setq status-string *cmail-pop3glue-disp-info-cache)
      (setq status-list (cmail-pop3glue-get-status-list))
      (if (null status-list)
	  (setq status-string "*")
	(setq tmp-list status-list)
	(while tmp-list
	  (if (integerp (car tmp-list))
	      (progn
		(setq total-count (+ total-count (car tmp-list)))
		(setq any-success-p t)))
	  (setq tmp-list (cdr tmp-list)))
	(if any-success-p
	    (setq status-string (format "%d" total-count)))
	(if (or (memq 'cannot-open status-list)
		(memq 'connection-timeout status-list))
	    (setq status-string (concat status-string "-")))
	(if (memq 'auth-failure status-list)
	    (setq status-string (concat status-string "!"))))
      (setq *cmail-pop3glue-disp-info-cache status-string))
    (setq display-time-string
	  (format "%s Mail(%s)" prefix-string status-string))))

(defvar *cmail-pop3glue-account-list nil)
(defun cmail-pop3glue-get-status-list ()
  (let (tmp res (account-list *cmail-pop3glue-account-list))
    (while account-list
      (setq tmp (cmail-pop3glue-get-account-status
		 (car (car account-list)) (cdr (car account-list))))
      (if tmp (setq res (cons tmp res)))
      (setq account-list (cdr account-list)))
    res))

(defun cmail-pop3glue-get-account-status (server logname)
  (cmail-account-db-get server 'pop3 logname 'account-status))

(defun cmail-pop3glue-set-account-status (server logname status)
  (if (not (member (cons server logname) *cmail-pop3glue-account-list))
      (setq *cmail-pop3glue-account-list
	    (cons (cons server logname) *cmail-pop3glue-account-list)))
  (cmail-account-db-set server 'pop3 logname 'account-status status))

(provide 'cmail-pop3glue)
