git.chise.org Git - elisp/gnus.git-/blob - lisp/mml-smime.el

   1 ;;; mml-smime.el --- S/MIME support for MML
   2
   3 ;; Copyright (C) 2000, 2001, 2002, 2003, 2004,
   4 ;;   2005, 2006 Free Software Foundation, Inc.
   5
   6 ;; Author: Simon Josefsson <simon@josefsson.org>
   7 ;; Keywords: Gnus, MIME, S/MIME, MML
   8
   9 ;; This file is part of GNU Emacs.
  10
  11 ;; GNU Emacs is free software; you can redistribute it and/or modify
  12 ;; it under the terms of the GNU General Public License as published
  13 ;; by the Free Software Foundation; either version 2, or (at your
  14 ;; option) any later version.
  15
  16 ;; GNU Emacs is distributed in the hope that it will be useful, but
  17 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  19 ;; General Public License for more details.
  20
  21 ;; You should have received a copy of the GNU General Public License
  22 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  23 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  24 ;; Boston, MA 02110-1301, USA.
  25
  26 ;;; Commentary:
  27
  28 ;;; Code:
  29
  30 (eval-when-compile (require 'cl))
  31
  32 ;; EMIKO doesn't provide the smime.el module.
  33 (condition-case nil
  34     (require 'smime)
  35   (error))
  36 (require 'mm-decode)
  37 (autoload 'message-narrow-to-headers "message")
  38 (autoload 'message-fetch-field "message")
  39
  40 (defun mml-smime-sign (cont)
  41   (when (null smime-keys)
  42     (customize-variable 'smime-keys)
  43     (error "No S/MIME keys configured, use customize to add your key"))
  44   (smime-sign-buffer (cdr (assq 'keyfile cont)))
  45   (goto-char (point-min))
  46   (while (search-forward "\r\n" nil t)
  47     (replace-match "\n" t t))
  48   (goto-char (point-max)))
  49
  50 (defun mml-smime-encrypt (cont)
  51   (let (certnames certfiles tmp file tmpfiles)
  52     ;; xxx tmp files are always an security issue
  53     (while (setq tmp (pop cont))
  54       (if (and (consp tmp) (eq (car tmp) 'certfile))
  55           (push (cdr tmp) certnames)))
  56     (while (setq tmp (pop certnames))
  57       (if (not (and (not (file-exists-p tmp))
  58                     (get-buffer tmp)))
  59           (push tmp certfiles)
  60         (setq file (mm-make-temp-file (expand-file-name "mml."
  61                                                         mm-tmp-directory)))
  62         (with-current-buffer tmp
  63           (write-region (point-min) (point-max) file))
  64         (push file certfiles)
  65         (push file tmpfiles)))
  66     (if (smime-encrypt-buffer certfiles)
  67         (progn
  68           (while (setq tmp (pop tmpfiles))
  69             (delete-file tmp))
  70           t)
  71       (while (setq tmp (pop tmpfiles))
  72         (delete-file tmp))
  73       nil))
  74   (goto-char (point-max)))
  75
  76 (defun mml-smime-sign-query ()
  77   ;; query information (what certificate) from user when MML tag is
  78   ;; added, for use later by the signing process
  79   (when (null smime-keys)
  80     (customize-variable 'smime-keys)
  81     (error "No S/MIME keys configured, use customize to add your key"))
  82   (list 'keyfile
  83         (if (= (length smime-keys) 1)
  84             (cadar smime-keys)
  85           (or (let ((from (cadr (funcall (if (boundp
  86                                               'gnus-extract-address-components)
  87                                              gnus-extract-address-components
  88                                            'mail-extract-address-components)
  89                                          (or (save-excursion
  90                                                (save-restriction
  91                                                  (message-narrow-to-headers)
  92                                                  (message-fetch-field "from")))
  93                                              "")))))
  94                 (and from (smime-get-key-by-email from)))
  95               (smime-get-key-by-email
  96                (completing-read "Sign this part with what signature? "
  97                                 smime-keys nil nil
  98                                 (and (listp (car-safe smime-keys))
  99                                      (caar smime-keys))))))))
 100
 101 (defun mml-smime-get-file-cert ()
 102   (ignore-errors
 103     (list 'certfile (read-file-name
 104                      "File with recipient's S/MIME certificate: "
 105                      smime-certificate-directory nil t ""))))
 106
 107 (defun mml-smime-get-dns-cert ()
 108   ;; todo: deal with comma separated multiple recipients
 109   (let (result who bad cert)
 110     (condition-case ()
 111         (while (not result)
 112           (setq who (read-from-minibuffer
 113                      (format "%sLookup certificate for: " (or bad ""))
 114                      (cadr (funcall (if (boundp
 115                                          'gnus-extract-address-components)
 116                                         gnus-extract-address-components
 117                                       'mail-extract-address-components)
 118                                     (or (save-excursion
 119                                           (save-restriction
 120                                             (message-narrow-to-headers)
 121                                             (message-fetch-field "to")))
 122                                         "")))))
 123           (if (setq cert (smime-cert-by-dns who))
 124               (setq result (list 'certfile (buffer-name cert)))
 125             (setq bad (format "`%s' not found. " who))))
 126       (quit))
 127     result))
 128
 129 (defun mml-smime-get-ldap-cert ()
 130   ;; todo: deal with comma separated multiple recipients
 131   (let (result who bad cert)
 132     (condition-case ()
 133         (while (not result)
 134           (setq who (read-from-minibuffer
 135                      (format "%sLookup certificate for: " (or bad ""))
 136                      (cadr (funcall gnus-extract-address-components
 137                                     (or (save-excursion
 138                                           (save-restriction
 139                                             (message-narrow-to-headers)
 140                                             (message-fetch-field "to")))
 141                                         "")))))
 142           (if (setq cert (smime-cert-by-ldap who))
 143               (setq result (list 'certfile (buffer-name cert)))
 144             (setq bad (format "`%s' not found. " who))))
 145       (quit))
 146     result))
 147
 148 (defun mml-smime-encrypt-query ()
 149   ;; todo: try dns/ldap automatically first, before prompting user
 150   (let (certs done)
 151     (while (not done)
 152       (ecase (read (gnus-completing-read-with-default
 153                     "ldap" "Fetch certificate from"
 154                     '(("dns") ("ldap") ("file")) nil t))
 155         (dns (setq certs (append certs
 156                                  (mml-smime-get-dns-cert))))
 157         (ldap (setq certs (append certs
 158                                   (mml-smime-get-ldap-cert))))
 159         (file (setq certs (append certs
 160                                   (mml-smime-get-file-cert)))))
 161       (setq done (not (y-or-n-p "Add more recipients? "))))
 162     certs))
 163
 164 (defun mml-smime-verify (handle ctl)
 165   (with-temp-buffer
 166     (insert-buffer-substring (mm-handle-multipart-original-buffer ctl))
 167     (goto-char (point-min))
 168     (insert (format "Content-Type: %s; " (mm-handle-media-type ctl)))
 169     (insert (format "protocol=\"%s\"; "
 170                     (mm-handle-multipart-ctl-parameter ctl 'protocol)))
 171     (insert (format "micalg=\"%s\"; "
 172                     (mm-handle-multipart-ctl-parameter ctl 'micalg)))
 173     (insert (format "boundary=\"%s\"\n\n"
 174                     (mm-handle-multipart-ctl-parameter ctl 'boundary)))
 175     (when (get-buffer smime-details-buffer)
 176       (kill-buffer smime-details-buffer))
 177     (let ((buf (current-buffer))
 178           (good-signature (smime-noverify-buffer))
 179           (good-certificate (and (or smime-CA-file smime-CA-directory)
 180                                  (smime-verify-buffer)))
 181           addresses openssl-output)
 182       (setq openssl-output (with-current-buffer smime-details-buffer
 183                              (buffer-string)))
 184       (if (not good-signature)
 185           (progn
 186             ;; we couldn't verify message, fail with openssl output as message
 187             (mm-set-handle-multipart-parameter
 188              mm-security-handle 'gnus-info "Failed")
 189             (mm-set-handle-multipart-parameter
 190              mm-security-handle 'gnus-details
 191              (concat "OpenSSL failed to verify message integrity:\n"
 192                      "-------------------------------------------\n"
 193                      openssl-output)))
 194         ;; verify mail addresses in mail against those in certificate
 195         (when (and (smime-pkcs7-region (point-min) (point-max))
 196                    (smime-pkcs7-certificates-region (point-min) (point-max)))
 197           (with-temp-buffer
 198             (insert-buffer-substring buf)
 199             (goto-char (point-min))
 200             (while (re-search-forward "-----END CERTIFICATE-----" nil t)
 201               (when (smime-pkcs7-email-region (point-min) (point))
 202                 (setq addresses (append (smime-buffer-as-string-region
 203                                          (point-min) (point)) addresses)))
 204               (delete-region (point-min) (point)))
 205             (setq addresses (mapcar 'downcase addresses))))
 206         (if (not (member (downcase (or (mm-handle-multipart-from ctl) "")) addresses))
 207             (mm-set-handle-multipart-parameter
 208              mm-security-handle 'gnus-info "Sender address forged")
 209           (if good-certificate
 210               (mm-set-handle-multipart-parameter
 211                mm-security-handle 'gnus-info "Ok (sender authenticated)")
 212             (mm-set-handle-multipart-parameter
 213              mm-security-handle 'gnus-info "Ok (sender not trusted)")))
 214         (mm-set-handle-multipart-parameter
 215          mm-security-handle 'gnus-details
 216          (concat "Sender claimed to be: " (mm-handle-multipart-from ctl) "\n"
 217                  (if addresses
 218                      (concat "Addresses in certificate: "
 219                              (mapconcat 'identity addresses ", "))
 220                    "No addresses found in certificate. (Requires OpenSSL 0.9.6 or later.)")
 221                  "\n" "\n"
 222                  "OpenSSL output:\n"
 223                  "---------------\n" openssl-output "\n"
 224                  "Certificate(s) inside S/MIME signature:\n"
 225                  "---------------------------------------\n"
 226                  (buffer-string) "\n")))))
 227   handle)
 228
 229 (defun mml-smime-verify-test (handle ctl)
 230   smime-openssl-program)
 231
 232 (provide 'mml-smime)
 233
 234 ;;; mml-smime.el ends here