cgit.sxemacs.org Git - gnus/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 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 (defvar gnus-extract-address-components)
  33
  34 (require 'smime)
  35 (require 'mm-decode)
  36 (autoload 'message-narrow-to-headers "message")
  37 (autoload 'message-fetch-field "message")
  38
  39 (defun mml-smime-sign (cont)
  40   (when (null smime-keys)
  41     (customize-variable 'smime-keys)
  42     (error "No S/MIME keys configured, use customize to add your key"))
  43   (smime-sign-buffer (cdr (assq 'keyfile cont)))
  44   (goto-char (point-min))
  45   (while (search-forward "\r\n" nil t)
  46     (replace-match "\n" t t))
  47   (goto-char (point-max)))
  48
  49 (defun mml-smime-encrypt (cont)
  50   (let (certnames certfiles tmp file tmpfiles)
  51     ;; xxx tmp files are always an security issue
  52     (while (setq tmp (pop cont))
  53       (if (and (consp tmp) (eq (car tmp) 'certfile))
  54           (push (cdr tmp) certnames)))
  55     (while (setq tmp (pop certnames))
  56       (if (not (and (not (file-exists-p tmp))
  57                     (get-buffer tmp)))
  58           (push tmp certfiles)
  59         (setq file (mm-make-temp-file (expand-file-name "mml."
  60                                                         mm-tmp-directory)))
  61         (with-current-buffer tmp
  62           (write-region (point-min) (point-max) file))
  63         (push file certfiles)
  64         (push file tmpfiles)))
  65     (if (smime-encrypt-buffer certfiles)
  66         (progn
  67           (while (setq tmp (pop tmpfiles))
  68             (delete-file tmp))
  69           t)
  70       (while (setq tmp (pop tmpfiles))
  71         (delete-file tmp))
  72       nil))
  73   (goto-char (point-max)))
  74
  75 (defun mml-smime-sign-query ()
  76   ;; query information (what certificate) from user when MML tag is
  77   ;; added, for use later by the signing process
  78   (when (null smime-keys)
  79     (customize-variable 'smime-keys)
  80     (error "No S/MIME keys configured, use customize to add your key"))
  81   (list 'keyfile
  82         (if (= (length smime-keys) 1)
  83             (cadar smime-keys)
  84           (or (let ((from (cadr (funcall (if (boundp
  85                                               'gnus-extract-address-components)
  86                                              gnus-extract-address-components
  87                                            'mail-extract-address-components)
  88                                          (or (save-excursion
  89                                                (save-restriction
  90                                                  (message-narrow-to-headers)
  91                                                  (message-fetch-field "from")))
  92                                              "")))))
  93                 (and from (smime-get-key-by-email from)))
  94               (smime-get-key-by-email
  95                (completing-read "Sign this part with what signature? "
  96                                 smime-keys nil nil
  97                                 (and (listp (car-safe smime-keys))
  98                                      (caar smime-keys))))))))
  99
 100 (defun mml-smime-get-file-cert ()
 101   (ignore-errors
 102     (list 'certfile (read-file-name
 103                      "File with recipient's S/MIME certificate: "
 104                      smime-certificate-directory nil t ""))))
 105
 106 (defun mml-smime-get-dns-cert ()
 107   ;; todo: deal with comma separated multiple recipients
 108   (let (result who bad cert)
 109     (condition-case ()
 110         (while (not result)
 111           (setq who (read-from-minibuffer
 112                      (format "%sLookup certificate for: " (or bad ""))
 113                      (cadr (funcall (if (boundp
 114                                          'gnus-extract-address-components)
 115                                         gnus-extract-address-components
 116                                       'mail-extract-address-components)
 117                                     (or (save-excursion
 118                                           (save-restriction
 119                                             (message-narrow-to-headers)
 120                                             (message-fetch-field "to")))
 121                                         "")))))
 122           (if (setq cert (smime-cert-by-dns who))
 123               (setq result (list 'certfile (buffer-name cert)))
 124             (setq bad (format "`%s' not found. " who))))
 125       (quit))
 126     result))
 127
 128 (defun mml-smime-get-ldap-cert ()
 129   ;; todo: deal with comma separated multiple recipients
 130   (let (result who bad cert)
 131     (condition-case ()
 132         (while (not result)
 133           (setq who (read-from-minibuffer
 134                      (format "%sLookup certificate for: " (or bad ""))
 135                      (cadr (funcall gnus-extract-address-components
 136                                     (or (save-excursion
 137                                           (save-restriction
 138                                             (message-narrow-to-headers)
 139                                             (message-fetch-field "to")))
 140                                         "")))))
 141           (if (setq cert (smime-cert-by-ldap who))
 142               (setq result (list 'certfile (buffer-name cert)))
 143             (setq bad (format "`%s' not found. " who))))
 144       (quit))
 145     result))
 146
 147 (defun mml-smime-encrypt-query ()
 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 ;;; arch-tag: f1bf94d4-f2cd-4c6f-b059-ad69492817e2
 234 ;;; mml-smime.el ends here