(shr-tag-li): Get <li> indentation right.

[gnus] / lisp / mml-smime.el

diff --git a/lisp/mml-smime.el b/lisp/mml-smime.el
index 82d13df..62e742f 100644 (file)
--- a/lisp/mml-smime.el
+++ b/lisp/mml-smime.el
@@ -1,42 +1,119 @@
 ;;; mml-smime.el --- S/MIME support for MML
 ;;; mml-smime.el --- S/MIME support for MML

-;; Copyright (c) 2000, 2001, 2003 Free Software Foundation, Inc.
+
+;; Copyright (C) 2000, 2001, 2002, 2003, 2004,
+;;   2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.

 
 ;; Author: Simon Josefsson <simon@josefsson.org>
 ;; Keywords: Gnus, MIME, S/MIME, MML
 
 ;; This file is part of GNU Emacs.
 
 
 ;; Author: Simon Josefsson <simon@josefsson.org>
 ;; Keywords: Gnus, MIME, S/MIME, MML
 
 ;; This file is part of GNU Emacs.
 

-;; GNU Emacs 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.
+;; GNU Emacs 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 3 of the License, or
+;; (at your option) any later version.

 
 

-;; GNU Emacs 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.
+;; GNU Emacs 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
 
 ;; You should have received a copy of the GNU General Public License

-;; along with GNU Emacs; see the file COPYING.  If not, write to the
-;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
-;; Boston, MA 02111-1307, USA.
+;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.

 
 ;;; Commentary:
 
 ;;; Code:
 
 
 ;;; Commentary:
 
 ;;; Code:
 

+;; For Emacs < 22.2.
+(eval-and-compile
+  (unless (fboundp 'declare-function) (defmacro declare-function (&rest r))))
+
+(eval-when-compile (require 'cl))
+

 (require 'smime)
 (require 'mm-decode)
 (require 'smime)
 (require 'mm-decode)

+(require 'mml-sec)

 (autoload 'message-narrow-to-headers "message")
 (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-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)
 
 (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"))
   (smime-sign-buffer (cdr (assq 'keyfile cont)))
   (when (null smime-keys)
     (customize-variable 'smime-keys)
     (error "No S/MIME keys configured, use customize to add your key"))
   (smime-sign-buffer (cdr (assq 'keyfile cont)))

+  (goto-char (point-min))
+  (while (search-forward "\r\n" nil t)
+    (replace-match "\n" t t))

   (goto-char (point-max)))
 
   (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))
   (let (certnames certfiles tmp file tmpfiles)
     ;; xxx tmp files are always an security issue
     (while (setq tmp (pop cont))


@@ -46,7 +123,7 @@
       (if (not (and (not (file-exists-p tmp))
                    (get-buffer tmp)))
          (push tmp certfiles)
       (if (not (and (not (file-exists-p tmp))
                    (get-buffer tmp)))
          (push tmp certfiles)

-       (setq file (mm-make-temp-file (expand-file-name "mml." 
+       (setq file (mm-make-temp-file (expand-file-name "mml."

                                                        mm-tmp-directory)))
        (with-current-buffer tmp
          (write-region (point-min) (point-max) file))
                                                        mm-tmp-directory)))
        (with-current-buffer tmp
          (write-region (point-min) (point-max) file))


@@ -62,7 +139,9 @@
       nil))
   (goto-char (point-max)))
 
       nil))
   (goto-char (point-max)))
 

-(defun mml-smime-sign-query ()
+(defvar gnus-extract-address-components)
+
+(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)
   ;; query information (what certificate) from user when MML tag is
   ;; added, for use later by the signing process
   (when (null smime-keys)


@@ -71,7 +150,10 @@
   (list 'keyfile
        (if (= (length smime-keys) 1)
            (cadar smime-keys)
   (list 'keyfile
        (if (= (length smime-keys) 1)
            (cadar smime-keys)

-         (or (let ((from (cadr (funcall gnus-extract-address-components
+         (or (let ((from (cadr (funcall (if (boundp
+                                             'gnus-extract-address-components)
+                                            gnus-extract-address-components
+                                          'mail-extract-address-components)

                                         (or (save-excursion
                                               (save-restriction
                                                 (message-narrow-to-headers)
                                         (or (save-excursion
                                               (save-restriction
                                                 (message-narrow-to-headers)


@@ -79,10 +161,10 @@
                                             "")))))
                (and from (smime-get-key-by-email from)))
              (smime-get-key-by-email
                                             "")))))
                (and from (smime-get-key-by-email from)))
              (smime-get-key-by-email

-              (completing-read "Sign this part with what signature? "
-                               smime-keys nil nil
-                               (and (listp (car-safe smime-keys))
-                                    (caar smime-keys))))))))
+              (gnus-completing-read "Sign this part with what signature"
+                                     smime-keys nil nil
+                                     (and (listp (car-safe smime-keys))
+                                          (caar smime-keys))))))))

 
 (defun mml-smime-get-file-cert ()
   (ignore-errors
 
 (defun mml-smime-get-file-cert ()
   (ignore-errors


@@ -97,7 +179,10 @@
        (while (not result)
          (setq who (read-from-minibuffer
                     (format "%sLookup certificate for: " (or bad ""))
        (while (not result)
          (setq who (read-from-minibuffer
                     (format "%sLookup certificate for: " (or bad ""))

-                    (cadr (funcall gnus-extract-address-components
+                    (cadr (funcall (if (boundp
+                                        'gnus-extract-address-components)
+                                       gnus-extract-address-components
+                                     'mail-extract-address-components)

                                    (or (save-excursion
                                          (save-restriction
                                            (message-narrow-to-headers)
                                    (or (save-excursion
                                          (save-restriction
                                            (message-narrow-to-headers)


@@ -109,22 +194,45 @@
       (quit))
     result))
 
       (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))
+
+(autoload 'gnus-completing-read "gnus-util")
+
+(defun mml-smime-openssl-encrypt-query ()

   ;; todo: try dns/ldap automatically first, before prompting user
   (let (certs done)
     (while (not done)
   ;; 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))
+      (ecase (read (gnus-completing-read
+                   "Fetch certificate from"
+                   '(("dns") ("ldap") ("file")) t nil nil
+                    "ldap"))

        (dns (setq certs (append certs
                                 (mml-smime-get-dns-cert))))
        (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))
 
        (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))
   (with-temp-buffer
     (insert-buffer-substring (mm-handle-multipart-original-buffer ctl))
     (go