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

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