;;
;; imap.el support RFC1730/2060 (IMAP4/IMAP4rev1), implemented IMAP
;; extensions are RFC2195 (CRAM-MD5), RFC2086 (ACL), RFC2342
-;; (NAMESPACE), RFC2359 (UIDPLUS), and the kerberos V4 part of RFC1731
-;; (with use of external program `imtest'). It also take advantage
-;; the UNSELECT extension in Cyrus IMAPD.
+;; (NAMESPACE), RFC2359 (UIDPLUS), the IMAP-part of RFC2595 (STARTTLS)
+;; (with use of external library starttls.el and program starttls) and
+;; the GSSAPI / kerberos V4 sections of RFC1731 (with use of external
+;; program `imtest'). It also take advantage the UNSELECT extension
+;; in Cyrus IMAPD.
;;
;; Without the work of John McClary Prevost and Jim Radford this library
;; would not have seen the light of day. Many thanks.
;; o Don't use `read' at all (important places already fixed)
;; o Accept list of articles instead of message set string in most
;; imap-message-* functions.
-;; o Cyrus IMAPd 1.6.x `imtest' support in the imtest wrapper
;;
;; Revision history:
;;
;; User variables.
-(defvar imap-imtest-program "imtest -kp %s %p"
- "How to call program for Kerberos 4 authentication.
-%s is replaced with server and %p with port to connect to. The
-program should accept IMAP commands on stdin and return responses to
-stdout.")
+(defvar imap-kerberos4-program '("imtest -m kerberos_v4 -u %l -p %p %s"
+ "imtest -kp %s %p")
+ "List of strings containing commands for Kerberos 4 authentication.
+%s is replaced with server hostname, %p with port to connect to, and
+%l with the value of `imap-default-user'. The program should accept
+IMAP commands on stdin and return responses to stdout.")
+
+(defvar imap-gssapi-program '("imtest -m gssapi -u %l -p %p %s")
+ "List of strings containing commands for GSSAPI (krb5) authentication.
+%s is replaced with server hostname, %p with port to connect to, and
+%l with the value of `imap-default-user'. The program should accept
+IMAP commands on stdin and return responses to stdout.")
(defvar imap-ssl-program '("openssl s_client -ssl3 -connect %s:%p"
"openssl s_client -ssl2 -connect %s:%p"
(defvar imap-fetch-data-hook nil
"Hooks called after receiving each FETCH response.")
-(defvar imap-streams '(kerberos4 starttls ssl network)
+(defvar imap-streams '(gssapi kerberos4 starttls ssl network)
"Priority of streams to consider when opening connection to server.")
(defvar imap-stream-alist
- '((kerberos4 imap-kerberos4s-p imap-kerberos4-open)
- (ssl imap-ssl-p imap-ssl-open)
- (network imap-network-p imap-network-open)
- (starttls imap-starttls-p imap-starttls-open))
+ '((gssapi imap-gssapi-stream-p imap-gssapi-open)
+ (kerberos4 imap-kerberos4-stream-p imap-kerberos4-open)
+ (ssl imap-ssl-p imap-ssl-open)
+ (network imap-network-p imap-network-open)
+ (starttls imap-starttls-p imap-starttls-open))
"Definition of network streams.
(NAME CHECK OPEN)
server support the stream and OPEN is a function for opening the
stream.")
-(defvar imap-authenticators '(kerberos4 digest-md5 cram-md5 login anonymous)
+(defvar imap-authenticators '(gssapi
+ kerberos4
+ digest-md5
+ cram-md5
+ login
+ anonymous)
"Priority of authenticators to consider when authenticating to server.")
(defvar imap-authenticator-alist
- '((kerberos4 imap-kerberos4a-p imap-kerberos4-auth)
- (cram-md5 imap-cram-md5-p imap-cram-md5-auth)
- (login imap-login-p imap-login-auth)
- (anonymous imap-anonymous-p imap-anonymous-auth)
- (digest-md5 imap-digest-md5-p imap-digest-md5-auth))
+ '((gssapi imap-gssapi-auth-p imap-gssapia-auth)
+ (kerberos4 imap-kerberos4-auth-p imap-kerberos4-auth)
+ (cram-md5 imap-cram-md5-p imap-cram-md5-auth)
+ (login imap-login-p imap-login-auth)
+ (anonymous imap-anonymous-p imap-anonymous-auth)
+ (digest-md5 imap-digest-md5-p imap-digest-md5-auth))
"Definition of authenticators.
(NAME CHECK AUTHENTICATE)
\f
;; Server functions; stream stuff:
-(defun imap-kerberos4s-p (buffer)
+(defun imap-kerberos4-stream-p (buffer)
(imap-capability 'AUTH=KERBEROS_V4 buffer))
(defun imap-kerberos4-open (name buffer server port)
- (message "Opening Kerberized IMAP connection...")
- (let* ((port (or port imap-default-port))
- (coding-system-for-read imap-coding-system-for-read)
- (coding-system-for-write imap-coding-system-for-write)
- (process (start-process
- name buffer shell-file-name shell-command-switch
- (format-spec
- imap-imtest-program
- (format-spec-make ?s server ?p (number-to-string port))))))
- (when process
- (with-current-buffer buffer
- (setq imap-client-eol "\n")
- ;; Result of authentication is a string: __Full privacy protection__
- (while (and (memq (process-status process) '(open run))
- (goto-char (point-min))
- (not (and (imap-parse-greeting)
- (re-search-forward "__\\(.*\\)__\n" nil t))))
- (accept-process-output process 1)
- (sit-for 1))
- (and imap-log
- (with-current-buffer (get-buffer-create imap-log)
- (imap-disable-multibyte)
- (buffer-disable-undo)
- (goto-char (point-max))
- (insert-buffer-substring buffer)))
- (let ((response (match-string 1)))
- (erase-buffer)
- (message "Kerberized IMAP connection: %s" response)
- (if (and response (let ((case-fold-search nil))
- (not (string-match "failed" response))))
- process
- (if (memq (process-status process) '(open run))
- (imap-send-command-wait "LOGOUT"))
- (delete-process process)
- nil))))))
+ (let ((cmds imap-kerberos4-program)
+ cmd done)
+ (while (and (not done) (setq cmd (pop cmds)))
+ (message "Opening Kerberos 4 IMAP connection with `%s'..." cmd)
+ (let* ((port (or port imap-default-port))
+ (coding-system-for-read imap-coding-system-for-read)
+ (coding-system-for-write imap-coding-system-for-write)
+ (process (start-process
+ name buffer shell-file-name shell-command-switch
+ (format-spec
+ cmd
+ (format-spec-make
+ ?s server
+ ?p (number-to-string port)
+ ?l imap-default-user))))
+ response)
+ (when process
+ (with-current-buffer buffer
+ (setq imap-client-eol "\n")
+ (while (and (memq (process-status process) '(open run))
+ (goto-char (point-min))
+ ;; cyrus 1.6 imtest print "S: " before server greeting
+ (or (not (looking-at "S: "))
+ (forward-char 3)
+ t)
+ (not (and (imap-parse-greeting)
+ ;; success in imtest < 1.6:
+ (or (re-search-forward
+ "^__\\(.*\\)__\n" nil t)
+ ;; success in imtest 1.6:
+ (re-search-forward
+ "^\\(Authenticat.*\\)" nil t))
+ (setq response (match-string 1)))))
+ (accept-process-output process 1)
+ (sit-for 1))
+ (and imap-log
+ (with-current-buffer (get-buffer-create imap-log)
+ (imap-disable-multibyte)
+ (buffer-disable-undo)
+ (goto-char (point-max))
+ (insert-buffer-substring buffer)))
+ (erase-buffer)
+ (message "Kerberos 4 IMAP connection: %s" (or response "failed"))
+ (if (and response (let ((case-fold-search nil))
+ (not (string-match "failed" response))))
+ (setq done process)
+ (if (memq (process-status process) '(open run))
+ (imap-send-command-wait "LOGOUT"))
+ (delete-process process)
+ nil)))))
+ done))
+(defun imap-gssapi-stream-p (buffer)
+ (imap-capability 'AUTH=GSSAPI buffer))
+
+(defun imap-gssapi-open (name buffer server port)
+ (let ((cmds imap-gssapi-program)
+ cmd done)
+ (while (and (not done) (setq cmd (pop cmds)))
+ (message "Opening GSSAPI IMAP connection with `%s'..." cmd)
+ (let* ((port (or port imap-default-port))
+ (coding-system-for-read imap-coding-system-for-read)
+ (coding-system-for-write imap-coding-system-for-write)
+ (process (start-process
+ name buffer shell-file-name shell-command-switch
+ (format-spec
+ cmd
+ (format-spec-make
+ ?s server
+ ?p (number-to-string port)
+ ?l imap-default-user))))
+ response)
+ (when process
+ (with-current-buffer buffer
+ (setq imap-client-eol "\n")
+ (while (and (memq (process-status process) '(open run))
+ (goto-char (point-min))
+ ;; cyrus 1.6 imtest print "S: " before server greeting
+ (or (not (looking-at "S: "))
+ (forward-char 3)
+ t)
+ (not (and (imap-parse-greeting)
+ ;; success in imtest 1.6:
+ (re-search-forward
+ "^\\(Authenticat.*\\)" nil t)
+ (setq response (match-string 1)))))
+ (accept-process-output process 1)
+ (sit-for 1))
+ (and imap-log
+ (with-current-buffer (get-buffer-create imap-log)
+ (imap-disable-multibyte)
+ (buffer-disable-undo)
+ (goto-char (point-max))
+ (insert-buffer-substring buffer)))
+ (erase-buffer)
+ (message "GSSAPI IMAP connection: %s" (or response "failed"))
+ (if (and response (let ((case-fold-search nil))
+ (not (string-match "failed" response))))
+ (setq done process)
+ (if (memq (process-status process) '(open run))
+ (imap-send-command-wait "LOGOUT"))
+ (delete-process process)
+ nil)))))
+ done))
+
(defun imap-ssl-p (buffer)
nil)
;; passwd nil))))
ret)))
-(defun imap-kerberos4a-p (buffer)
+(defun imap-gssapi-auth-p (buffer)
+ (imap-capability 'AUTH=GSSAPI buffer))
+
+(defun imap-gssapi-auth (buffer)
+ (eq imap-stream 'gssapi))
+
+(defun imap-kerberos4-auth-p (buffer)
(imap-capability 'AUTH=KERBEROS_V4 buffer))
(defun imap-kerberos4-auth (buffer)
(if (not (eq (imap-wait-for-tag tag) 'INCOMPLETE))
(setq command nil);; abort command if no cont-req
(let ((process imap-process)
- (stream imap-stream))
+ (stream imap-stream)
+ (eol imap-client-eol))
(with-current-buffer cmd
- (when (not (equal imap-client-eol "\r\n"))
+ (when (not (equal eol "\r\n"))
;; XXX modifies buffer!
(goto-char (point-min))
(while (search-forward "\r\n" nil t)
- (replace-match imap-client-eol)))
+ (replace-match eol)))
(and imap-log
(with-current-buffer (get-buffer-create
imap-log)
projects / gnus / commitdiff