[Emacs-diffs] trunk r112923: lisp/gnus/sievel-manage.el: fully support STARTTLS, fix bit rot

[Katsumi Yamaoka]

------------------------------------------------------------
revno: 112923
revision-id: address@hidden
parent: address@hidden
author: Albert Krewinkel <address@hidden>
committer: Katsumi Yamaoka <address@hidden>
branch nick: trunk
timestamp: Tue 2013-06-11 07:32:25 +0000
message:
  lisp/gnus/sievel-manage.el: fully support STARTTLS, fix bit rot
  
  * Make sieve-manage-open work with STARTTLS: shorten stream managing
    functions by using open-protocol-stream to do most of the work.  Has
    the nice benefit of enabling STARTTLS.
  
  * Remove unneeded functions and options: the following functions and
    options are neither in the API, nor called by any other function, so
    they are deleted:
    - sieve-manage-network-p
    - sieve-manage-network-open
    - sieve-manage-starttls-p
    - sieve-manage-starttls-open
    - sieve-manage-forward
    - sieve-manage-streams
    - sieve-manage-stream-alist
  
    The options could not be applied in a meaningful way anymore; they
    didn't happen to have much effect before.
  
  * Cosmetic changes and code clean-up
  
  * Enable Multibyte for SieveManage buffers: The parser won't properly
    handle umlauts and line endings unless multibyte is turned on in the
    process buffer.
  
  * Wait for capabilities after STARTTLS: following RFC5804, the server
    sends new capabilities after successfully establishing a TLS
    connection with the client.  The client should update the cached list
    of capabilities, but we just ignore the answer for now.
modified:
  lisp/gnus/ChangeLog            changelog-20091113204419-o5vbwnq5f7feedwu-1433
  lisp/gnus/sieve-manage.el      
sievemanage.el-20091113204419-o5vbwnq5f7feedwu-3281

=== modified file 'lisp/gnus/ChangeLog'
--- a/lisp/gnus/ChangeLog       2013-06-11 03:09:59 +0000
+++ b/lisp/gnus/ChangeLog       2013-06-11 07:32:25 +0000
@@ -1,3 +1,21 @@
+2013-06-10  Albert Krewinkel  <address@hidden>
+
+       * sieve-manage.el (sieve-manage-open): work with STARTTLS: shorten
+       stream managing functions by using open-protocol-stream to do most of
+       the work. Has the nice benefit of enabling STARTTLS.
+       Wait for capabilities after STARTTLS: following RFC5804, the server
+       sends new capabilities after successfully establishing a TLS connection
+       with the client. The client should update the cached list of
+       capabilities, but we just ignore the answer for now.
+       (sieve-manage-network-p, sieve-manage-network-open)
+       (sieve-manage-starttls-p, sieve-manage-starttls-open)
+       (sieve-manage-forward, sieve-manage-streams)
+       (sieve-manage-stream-alist): Remove unneeded functions neither in the
+       API, nor called by any other function.
+       Enable Multibyte for SieveManage buffers: The parser won't properly
+       handle umlauts and line endings unless multibyte is turned on in the
+       process buffer.
+
 2013-06-11  Lars Magne Ingebrigtsen  <address@hidden>
 
        * eww.el (eww-tag-input): Support password fields.

=== modified file 'lisp/gnus/sieve-manage.el'
--- a/lisp/gnus/sieve-manage.el 2013-04-27 23:57:29 +0000
+++ b/lisp/gnus/sieve-manage.el 2013-06-11 07:32:25 +0000
@@ -3,6 +3,7 @@
 ;; Copyright (C) 2001-2013 Free Software Foundation, Inc.
 
 ;; Author: Simon Josefsson <address@hidden>
+;;         Albert Krewinkel <address@hidden>
 
 ;; This file is part of GNU Emacs.
 
@@ -66,6 +67,7 @@
 ;; 2001-10-31 Committed to Oort Gnus.
 ;; 2002-07-27 Added DELETESCRIPT.  Suggested by Ned Ludd.
 ;; 2002-08-03 Use SASL library.
+;; 2013-06-05 Enabled STARTTLS support, fixed bit rot.
 
 ;;; Code:
 
@@ -82,7 +84,6 @@
   (require 'sasl)
   (require 'starttls))
 (autoload 'sasl-find-mechanism "sasl")
-(autoload 'starttls-open-stream "starttls")
 (autoload 'auth-source-search "auth-source")
 
 ;; User customizable variables:
@@ -107,23 +108,6 @@
   :type 'string
   :group 'sieve-manage)
 
-(defcustom sieve-manage-streams '(network starttls shell)
-  "Priority of streams to consider when opening connection to server."
-  :group 'sieve-manage)
-
-(defcustom sieve-manage-stream-alist
-  '((network   sieve-manage-network-p          sieve-manage-network-open)
-    (shell     sieve-manage-shell-p            sieve-manage-shell-open)
-    (starttls  sieve-manage-starttls-p         sieve-manage-starttls-open))
-  "Definition of network streams.
-
-\(NAME CHECK OPEN)
-
-NAME names the stream, CHECK is a function returning non-nil if the
-server support the stream and OPEN is a function for opening the
-stream."
-  :group 'sieve-manage)
-
 (defcustom sieve-manage-authenticators '(digest-md5
                                         cram-md5
                                         scram-md5
@@ -156,8 +140,7 @@
   :group 'sieve-manage)
 
 (defcustom sieve-manage-default-stream 'network
-  "Default stream type to use for `sieve-manage'.
-Must be a name of a stream in `sieve-manage-stream-alist'."
+  "Default stream type to use for `sieve-manage'."
   :version "24.1"
   :type 'symbol
   :group 'sieve-manage)
@@ -185,17 +168,21 @@
 (defvar sieve-manage-capability nil)
 
 ;; Internal utility functions
-
-(defmacro sieve-manage-disable-multibyte ()
-  "Enable multibyte in the current buffer."
-  (unless (featurep 'xemacs)
-    '(set-buffer-multibyte nil)))
+(defun sieve-manage-make-process-buffer ()
+  (with-current-buffer
+      (generate-new-buffer (format " *sieve %s:%s*"
+                                   sieve-manage-server
+                                   sieve-manage-port))
+    (mapc 'make-local-variable sieve-manage-local-variables)
+    (mm-enable-multibyte)
+    (buffer-disable-undo)
+    (current-buffer)))
 
 (defun sieve-manage-erase (&optional p buffer)
   (let ((buffer (or buffer (current-buffer))))
     (and sieve-manage-log
         (with-current-buffer (get-buffer-create sieve-manage-log)
-          (sieve-manage-disable-multibyte)
+          (mm-enable-multibyte)
           (buffer-disable-undo)
           (goto-char (point-max))
           (insert-buffer-substring buffer (with-current-buffer buffer
@@ -204,71 +191,32 @@
                                            (point-max)))))))
   (delete-region (point-min) (or p (point-max))))
 
-(defun sieve-manage-open-1 (buffer)
+(defun sieve-manage-open-server (server port &optional stream buffer)
+  "Open network connection to SERVER on PORT.
+Return the buffer associated with the connection."
   (with-current-buffer buffer
     (sieve-manage-erase)
-    (setq sieve-manage-state 'initial
-         sieve-manage-process
-         (condition-case ()
-             (funcall (nth 2 (assq sieve-manage-stream
-                                   sieve-manage-stream-alist))
-                      "sieve" buffer sieve-manage-server sieve-manage-port)
-           ((error quit) nil)))
-    (when sieve-manage-process
-      (while (and (eq sieve-manage-state 'initial)
-                 (memq (process-status sieve-manage-process) '(open run)))
-       (message "Waiting for response from %s..." sieve-manage-server)
-       (accept-process-output sieve-manage-process 1))
-      (message "Waiting for response from %s...done" sieve-manage-server)
-      (and (memq (process-status sieve-manage-process) '(open run))
-          sieve-manage-process))))
-
-;; Streams
-
-(defun sieve-manage-network-p (buffer)
-  t)
-
-(defun sieve-manage-network-open (name buffer server port)
-  (let* ((port (or port sieve-manage-default-port))
-        (coding-system-for-read sieve-manage-coding-system-for-read)
-        (coding-system-for-write sieve-manage-coding-system-for-write)
-        (process (open-network-stream name buffer server port)))
-    (when process
-      (while (and (memq (process-status process) '(open run))
-                 (set-buffer buffer) ;; XXX "blue moon" nntp.el bug
-                 (goto-char (point-min))
-                 (not (sieve-manage-parse-greeting-1)))
-       (accept-process-output process 1)
-       (sit-for 1))
-      (sieve-manage-erase nil buffer)
-      (when (memq (process-status process) '(open run))
-       process))))
-
-(defun sieve-manage-starttls-p (buffer)
-  (condition-case ()
-      (progn
-       (require 'starttls)
-       (call-process "starttls"))
-    (error nil)))
-
-(defun sieve-manage-starttls-open (name buffer server port)
-  (let* ((port (or port sieve-manage-default-port))
-        (coding-system-for-read sieve-manage-coding-system-for-read)
-        (coding-system-for-write sieve-manage-coding-system-for-write)
-        (process (starttls-open-stream name buffer server port))
-        done)
-    (when process
-      (while (and (memq (process-status process) '(open run))
-                 (set-buffer buffer) ;; XXX "blue moon" nntp.el bug
-                 (goto-char (point-min))
-                 (not (sieve-manage-parse-greeting-1)))
-       (accept-process-output process 1)
-       (sit-for 1))
-      (sieve-manage-erase nil buffer)
-      (sieve-manage-send "STARTTLS")
-      (starttls-negotiate process))
-    (when (memq (process-status process) '(open run))
-      process)))
+    (setq sieve-manage-state 'initial)
+    (destructuring-bind (proc . props)
+        (open-protocol-stream
+         "SIEVE" buffer server port
+         :type stream
+         :capability-command "CAPABILITY\r\n"
+         :end-of-command "^\\(OK\\|NO\\).*\n"
+         :success "^OK.*\n"
+         :return-list t
+         :starttls-function
+         '(lambda (capabilities)
+            (when (string-match "\\bSTARTTLS\\b" capabilities)
+              "STARTTLS\r\n")))
+      (setq sieve-manage-process proc)
+      (setq sieve-manage-capability
+            (sieve-manage-parse-capability (getf props :capabilities)))
+      ;; Ignore new capabilities issues after successful STARTTLS
+      (when (and (memq stream '(nil network starttls))
+                 (eq (getf props :type) 'tls))
+        (sieve-manage-drop-next-answer))
+      (current-buffer))))
 
 ;; Authenticators
 (defun sieve-sasl-auth (buffer mech)
@@ -396,63 +344,33 @@
 If nil, chooses the best stream the server is capable of.
 Optional argument BUFFER is buffer (buffer, or string naming buffer)
 to work in."
-  (or port (setq port sieve-manage-default-port))
-  (setq buffer (or buffer (format " *sieve* %s:%s" server port)))
-  (with-current-buffer (get-buffer-create buffer)
-    (mapc 'make-local-variable sieve-manage-local-variables)
-    (sieve-manage-disable-multibyte)
-    (buffer-disable-undo)
-    (setq sieve-manage-server (or server sieve-manage-server))
-    (setq sieve-manage-port port)
-    (setq sieve-manage-stream (or stream sieve-manage-stream))
+  (setq sieve-manage-port (or port sieve-manage-default-port))
+  (with-current-buffer (or buffer (sieve-manage-make-process-buffer))
+    (setq sieve-manage-server (or server
+                                  sieve-manage-server)
+          sieve-manage-stream (or stream
+                                  sieve-manage-stream
+                                  sieve-manage-default-stream)
+          sieve-manage-auth   (or auth
+                                  sieve-manage-auth))
     (message "sieve: Connecting to %s..." sieve-manage-server)
-    (if (let ((sieve-manage-stream
-              (or sieve-manage-stream sieve-manage-default-stream)))
-         (sieve-manage-open-1 buffer))
-       ;; Choose stream.
-       (let (stream-changed)
-         (message "sieve: Connecting to %s...done" sieve-manage-server)
-         (when (null sieve-manage-stream)
-           (let ((streams sieve-manage-streams))
-             (while (setq stream (pop streams))
-               (if (funcall (nth 1 (assq stream
-                                         sieve-manage-stream-alist)) buffer)
-                   (setq stream-changed
-                         (not (eq (or sieve-manage-stream
-                                      sieve-manage-default-stream)
-                                  stream))
-                         sieve-manage-stream stream
-                         streams nil)))
-             (unless sieve-manage-stream
-               (error "Couldn't figure out a stream for server"))))
-         (when stream-changed
-           (message "sieve: Reconnecting with stream `%s'..."
-                    sieve-manage-stream)
-           (sieve-manage-close buffer)
-           (if (sieve-manage-open-1 buffer)
-               (message "sieve: Reconnecting with stream `%s'...done"
-                        sieve-manage-stream)
-             (message "sieve: Reconnecting with stream `%s'...failed"
-                      sieve-manage-stream))
-           (setq sieve-manage-capability nil))
-         (if (sieve-manage-opened buffer)
-             ;; Choose authenticator
-             (when (and (null sieve-manage-auth)
-                        (not (eq sieve-manage-state 'auth)))
-               (let ((auths sieve-manage-authenticators))
-                 (while (setq auth (pop auths))
-                   (if (funcall (nth 1 (assq
-                                        auth
-                                        sieve-manage-authenticator-alist))
-                                buffer)
-                       (setq sieve-manage-auth auth
-                             auths nil)))
-                 (unless sieve-manage-auth
-                   (error "Couldn't figure out authenticator for server"))))))
-      (message "sieve: Connecting to %s...failed" sieve-manage-server))
-    (when (sieve-manage-opened buffer)
+    (sieve-manage-open-server sieve-manage-server
+                              sieve-manage-port
+                              sieve-manage-stream
+                              (current-buffer))
+    (when (sieve-manage-opened (current-buffer))
+      ;; Choose authenticator
+      (when (and (null sieve-manage-auth)
+                 (not (eq sieve-manage-state 'auth)))
+        (dolist (auth sieve-manage-authenticators)
+          (when (funcall (nth 1 (assq auth sieve-manage-authenticator-alist))
+                       buffer)
+            (setq sieve-manage-auth auth)
+            (return)))
+        (unless sieve-manage-auth
+          (error "Couldn't figure out authenticator for server")))
       (sieve-manage-erase)
-      buffer)))
+      (current-buffer))))
 
 (defun sieve-manage-authenticate (&optional buffer)
   "Authenticate on server in BUFFER.
@@ -544,12 +462,22 @@
 
 ;; Protocol parsing routines
 
+(defun sieve-manage-wait-for-answer ()
+  (let ((pattern "^\\(OK\\|NO\\).*\n")
+        pos)
+    (while (not pos)
+      (setq pos (search-forward-regexp pattern nil t))
+      (goto-char (point-min))
+      (sleep-for 0 50))
+    pos))
+
+(defun sieve-manage-drop-next-answer ()
+  (sieve-manage-wait-for-answer)
+  (sieve-manage-erase))
+
 (defun sieve-manage-ok-p (rsp)
   (string= (downcase (or (car-safe rsp) "")) "ok"))
 
-(defsubst sieve-manage-forward ()
-  (or (eobp) (forward-char)))
-
 (defun sieve-manage-is-okno ()
   (when (looking-at (concat
                     "^\\(OK\\|NO\\)\\( (\\([^)]+\\))\\)?\\( \\(.*\\)\\)?"
@@ -571,21 +499,15 @@
     (sieve-manage-erase)
     rsp))
 
-(defun sieve-manage-parse-capability-1 ()
-  "Accept a managesieve greeting."
-  (let (str)
-    (while (setq str (sieve-manage-is-string))
-      (if (eq (char-after) ? )
-         (progn
-           (sieve-manage-forward)
-           (push (list str (sieve-manage-is-string))
-                 sieve-manage-capability))
-       (push (list str) sieve-manage-capability))
-      (forward-line)))
-  (when (re-search-forward (concat "^OK.*" sieve-manage-server-eol) nil t)
-    (setq sieve-manage-state 'nonauth)))
-
-(defalias 'sieve-manage-parse-greeting-1 'sieve-manage-parse-capability-1)
+(defun sieve-manage-parse-capability (str)
+  "Parse managesieve capability string `STR'.
+Set variable `sieve-manage-capability' to "
+  (let ((capas (remove-if #'null
+                          (mapcar #'split-string-and-unquote
+                                  (split-string str "\n")))))
+    (when (string= "OK" (caar (last capas)))
+      (setq sieve-manage-state 'nonauth))
+    capas))
 
 (defun sieve-manage-is-string ()
   (cond ((looking-at "\"\\([^\"]+\\)\"")
@@ -639,7 +561,7 @@
   (setq cmdstr (concat cmdstr sieve-manage-client-eol))
   (and sieve-manage-log
        (with-current-buffer (get-buffer-create sieve-manage-log)
-        (sieve-manage-disable-multibyte)
+        (mm-enable-multibyte)
         (buffer-disable-undo)
         (goto-char (point-max))
         (insert cmdstr)))