[Emacs-diffs] Changes to emacs/lisp/gnus/mml-smime.el,v

[Miles Bader]

CVSROOT:        /cvsroot/emacs
Module name:    emacs
Changes by:     Miles Bader <miles>     07/10/28 09:18:40

Index: lisp/gnus/mml-smime.el
===================================================================
RCS file: /cvsroot/emacs/emacs/lisp/gnus/mml-smime.el,v
retrieving revision 1.11
retrieving revision 1.12
diff -u -b -r1.11 -r1.12
--- lisp/gnus/mml-smime.el      26 Jul 2007 05:27:02 -0000      1.11
+++ lisp/gnus/mml-smime.el      28 Oct 2007 09:18:27 -0000      1.12
@@ -31,10 +31,82 @@
 
 (require 'smime)
 (require 'mm-decode)
+(require 'mml-sec)
 (autoload 'message-narrow-to-headers "message")
 (autoload 'message-fetch-field "message")
 
+(defvar mml-smime-use 'openssl)
+
+(defvar mml-smime-function-alist
+  '((openssl mml-smime-openssl-sign
+            mml-smime-openssl-encrypt
+            mml-smime-openssl-sign-query
+            mml-smime-openssl-encrypt-query
+            mml-smime-openssl-verify
+            mml-smime-openssl-verify-test)
+    (epg mml-smime-epg-sign
+        mml-smime-epg-encrypt
+        nil
+        nil
+        mml-smime-epg-verify
+        mml-smime-epg-verify-test)))
+
+(defcustom mml-smime-verbose mml-secure-verbose
+  "If non-nil, ask the user about the current operation more verbosely."
+  :group 'mime-security
+  :type 'boolean)
+
+(defcustom mml-smime-cache-passphrase mml-secure-cache-passphrase
+  "If t, cache passphrase."
+  :group 'mime-security
+  :type 'boolean)
+
+(defcustom mml-smime-passphrase-cache-expiry mml-secure-passphrase-cache-expiry
+  "How many seconds the passphrase is cached.
+Whether the passphrase is cached at all is controlled by
+`mml-smime-cache-passphrase'."
+  :group 'mime-security
+  :type 'integer)
+
+(defcustom mml-smime-signers nil
+  "A list of your own key ID which will be used to sign a message."
+  :group 'mime-security
+  :type '(repeat (string :tag "Key ID")))
+
 (defun mml-smime-sign (cont)
+  (let ((func (nth 1 (assq mml-smime-use mml-smime-function-alist))))
+    (if func
+       (funcall func cont)
+      (error "Cannot find sign function"))))
+
+(defun mml-smime-encrypt (cont)
+  (let ((func (nth 2 (assq mml-smime-use mml-smime-function-alist))))
+    (if func
+       (funcall func cont)
+      (error "Cannot find encrypt function"))))
+
+(defun mml-smime-sign-query ()
+  (let ((func (nth 3 (assq mml-smime-use mml-smime-function-alist))))
+    (if func
+       (funcall func))))
+
+(defun mml-smime-encrypt-query ()
+  (let ((func (nth 4 (assq mml-smime-use mml-smime-function-alist))))
+    (if func
+       (funcall func))))
+
+(defun mml-smime-verify (handle ctl)
+  (let ((func (nth 5 (assq mml-smime-use mml-smime-function-alist))))
+    (if func
+       (funcall func handle ctl)
+      handle)))
+
+(defun mml-smime-verify-test (handle ctl)
+  (let ((func (nth 6 (assq mml-smime-use mml-smime-function-alist))))
+    (if func
+       (funcall func handle ctl))))
+
+(defun mml-smime-openssl-sign (cont)
   (when (null smime-keys)
     (customize-variable 'smime-keys)
     (error "No S/MIME keys configured, use customize to add your key"))
@@ -44,7 +116,7 @@
     (replace-match "\n" t t))
   (goto-char (point-max)))
 
-(defun mml-smime-encrypt (cont)
+(defun mml-smime-openssl-encrypt (cont)
   (let (certnames certfiles tmp file tmpfiles)
     ;; xxx tmp files are always an security issue
     (while (setq tmp (pop cont))
@@ -70,7 +142,7 @@
       nil))
   (goto-char (point-max)))
 
-(defun mml-smime-sign-query ()
+(defun mml-smime-openssl-sign-query ()
   ;; query information (what certificate) from user when MML tag is
   ;; added, for use later by the signing process
   (when (null smime-keys)
@@ -123,22 +195,42 @@
       (quit))
     result))
 
-(defun mml-smime-encrypt-query ()
-  ;; todo: add ldap support (xemacs ldap api?)
+(defun mml-smime-get-ldap-cert ()
+  ;; todo: deal with comma separated multiple recipients
+  (let (result who bad cert)
+    (condition-case ()
+       (while (not result)
+         (setq who (read-from-minibuffer
+                    (format "%sLookup certificate for: " (or bad ""))
+                    (cadr (funcall gnus-extract-address-components
+                                   (or (save-excursion
+                                         (save-restriction
+                                           (message-narrow-to-headers)
+                                           (message-fetch-field "to")))
+                                       "")))))
+         (if (setq cert (smime-cert-by-ldap who))
+             (setq result (list 'certfile (buffer-name cert)))
+           (setq bad (format "`%s' not found. " who))))
+      (quit))
+    result))
+
+(defun mml-smime-openssl-encrypt-query ()
   ;; todo: try dns/ldap automatically first, before prompting user
   (let (certs done)
     (while (not done)
       (ecase (read (gnus-completing-read-with-default
-                   "dns" "Fetch certificate from"
-                   '(("dns") ("file")) nil t))
+                   "ldap" "Fetch certificate from"
+                   '(("dns") ("ldap") ("file")) nil t))
        (dns (setq certs (append certs
                                 (mml-smime-get-dns-cert))))
+       (ldap (setq certs (append certs
+                                 (mml-smime-get-ldap-cert))))
        (file (setq certs (append certs
                                  (mml-smime-get-file-cert)))))
       (setq done (not (y-or-n-p "Add more recipients? "))))
     certs))
 
-(defun mml-smime-verify (handle ctl)
+(defun mml-smime-openssl-verify (handle ctl)
   (with-temp-buffer
     (insert-buffer-substring (mm-handle-multipart-original-buffer ctl))
     (goto-char (point-min))
@@ -203,9 +295,249 @@
                 (buffer-string) "\n")))))
   handle)
 
-(defun mml-smime-verify-test (handle ctl)
+(defun mml-smime-openssl-verify-test (handle ctl)
   smime-openssl-program)
 
+(eval-and-compile
+  (autoload 'epg-make-context "epg"))
+
+(eval-when-compile
+  (defvar epg-user-id-alist)
+  (defvar epg-digest-algorithm-alist)
+  (defvar inhibit-redisplay)
+  (autoload 'epg-context-set-armor "epg")
+  (autoload 'epg-context-set-signers "epg")
+  (autoload 'epg-context-result-for "epg")
+  (autoload 'epg-new-signature-digest-algorithm "epg")
+  (autoload 'epg-verify-result-to-string "epg")
+  (autoload 'epg-list-keys "epg")
+  (autoload 'epg-decrypt-string "epg")
+  (autoload 'epg-verify-string "epg")
+  (autoload 'epg-sign-string "epg")
+  (autoload 'epg-encrypt-string "epg")
+  (autoload 'epg-passphrase-callback-function "epg")
+  (autoload 'epg-context-set-passphrase-callback "epg")
+  (autoload 'epg-configuration "epg-config")
+  (autoload 'epg-expand-group "epg-config")
+  (autoload 'epa-select-keys "epa"))
+
+(eval-when-compile
+  (defvar password-cache-expiry)
+  (autoload 'password-read "password")
+  (autoload 'password-cache-add "password")
+  (autoload 'password-cache-remove "password"))
+
+(defvar mml-smime-epg-secret-key-id-list nil)
+
+(defun mml-smime-epg-passphrase-callback (context key-id ignore)
+  (if (eq key-id 'SYM)
+      (epg-passphrase-callback-function context key-id nil)
+    (let* (entry
+          (passphrase
+           (password-read
+            (if (eq key-id 'PIN)
+                "Passphrase for PIN: "
+              (if (setq entry (assoc key-id epg-user-id-alist))
+                  (format "Passphrase for %s %s: " key-id (cdr entry))
+                (format "Passphrase for %s: " key-id)))
+            (if (eq key-id 'PIN)
+                "PIN"
+              key-id))))
+      (when passphrase
+       (let ((password-cache-expiry mml-smime-passphrase-cache-expiry))
+         (password-cache-add key-id passphrase))
+       (setq mml-smime-epg-secret-key-id-list
+             (cons key-id mml-smime-epg-secret-key-id-list))
+       (copy-sequence passphrase)))))
+
+(defun mml-smime-epg-find-usable-key (keys usage)
+  (catch 'found
+    (while keys
+      (let ((pointer (epg-key-sub-key-list (car keys))))
+       (while pointer
+         (if (and (memq usage (epg-sub-key-capability (car pointer)))
+                  (not (memq (epg-sub-key-validity (car pointer))
+                             '(revoked expired))))
+             (throw 'found (car keys)))
+         (setq pointer (cdr pointer))))
+      (setq keys (cdr keys)))))
+
+(defun mml-smime-epg-sign (cont)
+  (let* ((inhibit-redisplay t)
+        (context (epg-make-context 'CMS))
+        (boundary (mml-compute-boundary cont))
+        signer-key
+        (signers
+         (or (message-options-get 'mml-smime-epg-signers)
+             (message-options-set
+             'mml-smime-epg-signers
+             (if mml-smime-verbose
+                 (epa-select-keys context "\
+Select keys for signing.
+If no one is selected, default secret key is used.  "
+                                  mml-smime-signers t)
+               (if mml-smime-signers
+                   (mapcar
+                    (lambda (signer)
+                      (setq signer-key (mml-smime-epg-find-usable-key
+                                        (epg-list-keys context signer t)
+                                        'sign))
+                      (unless (or signer-key
+                                  (y-or-n-p
+                                   (format "No secret key for %s; skip it? "
+                                           signer)))
+                        (error "No secret key for %s" signer))
+                      signer-key)
+                    mml-smime-signers))))))
+        signature micalg)
+    (epg-context-set-signers context signers)
+    (if mml-smime-cache-passphrase
+       (epg-context-set-passphrase-callback
+        context
+        #'mml-smime-epg-passphrase-callback))
+    (condition-case error
+       (setq signature (epg-sign-string context
+                                        (mm-replace-in-string (buffer-string)
+                                                              "\n" "\r\n")
+                                        t)
+             mml-smime-epg-secret-key-id-list nil)
+      (error
+       (while mml-smime-epg-secret-key-id-list
+        (password-cache-remove (car mml-smime-epg-secret-key-id-list))
+        (setq mml-smime-epg-secret-key-id-list
+              (cdr mml-smime-epg-secret-key-id-list)))
+       (signal (car error) (cdr error))))
+    (if (epg-context-result-for context 'sign)
+       (setq micalg (epg-new-signature-digest-algorithm
+                     (car (epg-context-result-for context 'sign)))))
+    (goto-char (point-min))
+    (insert (format "Content-Type: multipart/signed; boundary=\"%s\";\n"
+                   boundary))
+    (if micalg
+       (insert (format "\tmicalg=%s; "
+                       (downcase
+                        (cdr (assq micalg
+                                   epg-digest-algorithm-alist))))))
+    (insert "protocol=\"application/pkcs7-signature\"\n")
+    (insert (format "\n--%s\n" boundary))
+    (goto-char (point-max))
+    (insert (format "\n--%s\n" boundary))
+    (insert "Content-Type: application/pkcs7-signature; name=smime.p7s
+Content-Transfer-Encoding: base64
+Content-Disposition: attachment; filename=smime.p7s
+
+")
+    (insert (base64-encode-string signature) "\n")
+    (goto-char (point-max))
+    (insert (format "--%s--\n" boundary))
+    (goto-char (point-max))))
+
+(defun mml-smime-epg-encrypt (cont)
+  (let ((inhibit-redisplay t)
+       (context (epg-make-context 'CMS))
+       (config (epg-configuration))
+       (recipients (message-options-get 'mml-smime-epg-recipients))
+       cipher signers
+       (boundary (mml-compute-boundary cont))
+       recipient-key)
+    (unless recipients
+      (setq recipients
+           (apply #'nconc
+                  (mapcar
+                   (lambda (recipient)
+                     (or (epg-expand-group config recipient)
+                         (list recipient)))
+                   (split-string
+                    (or (message-options-get 'message-recipients)
+                        (message-options-set 'message-recipients
+                                             (read-string "Recipients: ")))
+                    "[ \f\t\n\r\v,]+"))))
+      (if mml-smime-verbose
+         (setq recipients
+               (epa-select-keys context "\
+Select recipients for encryption.
+If no one is selected, symmetric encryption will be performed.  "
+                                recipients))
+       (setq recipients
+             (mapcar
+              (lambda (recipient)
+                (setq recipient-key (mml-smime-epg-find-usable-key
+                                     (epg-list-keys context recipient)
+                                     'encrypt))
+                (unless (or recipient-key
+                            (y-or-n-p
+                             (format "No public key for %s; skip it? "
+                                     recipient)))
+                  (error "No public key for %s" recipient))
+                recipient-key)
+              recipients))
+       (unless recipients
+         (error "No recipient specified")))
+      (message-options-set 'mml-smime-epg-recipients recipients))
+    (if mml-smime-cache-passphrase
+       (epg-context-set-passphrase-callback
+        context
+        #'mml-smime-epg-passphrase-callback))
+    (condition-case error
+       (setq cipher
+             (epg-encrypt-string context (buffer-string) recipients)
+             mml-smime-epg-secret-key-id-list nil)
+      (error
+       (while mml-smime-epg-secret-key-id-list
+        (password-cache-remove (car mml-smime-epg-secret-key-id-list))
+        (setq mml-smime-epg-secret-key-id-list
+              (cdr mml-smime-epg-secret-key-id-list)))
+       (signal (car error) (cdr error))))
+    (delete-region (point-min) (point-max))
+    (goto-char (point-min))
+    (insert "\
+Content-Type: application/pkcs7-mime;
+ smime-type=enveloped-data;
+ name=smime.p7m
+Content-Transfer-Encoding: base64
+Content-Disposition: attachment; filename=smime.p7m
+
+")
+    (insert (base64-encode-string cipher))
+    (goto-char (point-max))))
+
+(defun mml-smime-epg-verify (handle ctl)
+  (catch 'error
+    (let ((inhibit-redisplay t)
+         context plain signature-file part signature)
+      (when (or (null (setq part (mm-find-raw-part-by-type
+                                 ctl (or (mm-handle-multipart-ctl-parameter
+                                          ctl 'protocol)
+                                         "application/pkcs7-signature")
+                                 t)))
+               (null (setq signature (mm-find-part-by-type
+                                      (cdr handle)
+                                      "application/pkcs7-signature"
+                                      nil t))))
+       (mm-set-handle-multipart-parameter
+        mm-security-handle 'gnus-info "Corrupted")
+       (throw 'error handle))
+      (setq part (mm-replace-in-string part "\n" "\r\n" t)
+           context (epg-make-context 'CMS))
+      (condition-case error
+         (setq plain (epg-verify-string context (mm-get-part signature) part))
+       (error
+        (mm-set-handle-multipart-parameter
+         mm-security-handle 'gnus-info "Failed")
+        (if (eq (car error) 'quit)
+            (mm-set-handle-multipart-parameter
+             mm-security-handle 'gnus-details "Quit.")
+          (mm-set-handle-multipart-parameter
+           mm-security-handle 'gnus-details (format "%S" error)))
+        (throw 'error handle)))
+      (mm-set-handle-multipart-parameter
+       mm-security-handle 'gnus-info
+       (epg-verify-result-to-string (epg-context-result-for context 'verify)))
+      handle)))
+
+(defun mml-smime-epg-verify-test (handle ctl)
+  t)
+
 (provide 'mml-smime)
 
 ;;; arch-tag: f1bf94d4-f2cd-4c6f-b059-ad69492817e2