cgit.sxemacs.org Git - gnus/blob - lisp/mml-sec.el

   1 ;;; mml-sec.el --- A package with security functions for MML documents
   2 ;; Copyright (C) 2000 Free Software Foundation, Inc.
   3
   4 ;; Author: Simon Josefsson <simon@josefsson.org>
   5 ;; This file is not part of GNU Emacs, but the same permissions apply.
   6
   7 ;; GNU Emacs is free software; you can redistribute it and/or modify
   8 ;; it under the terms of the GNU General Public License as published by
   9 ;; the Free Software Foundation; either version 2, or (at your option)
  10 ;; any later version.
  11
  12 ;; GNU Emacs is distributed in the hope that it will be useful,
  13 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  14 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15 ;; GNU General Public License for more details.
  16
  17 ;; You should have received a copy of the GNU General Public License
  18 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  19 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  20 ;; Boston, MA 02111-1307, USA.
  21
  22 ;;; Commentary:
  23
  24 ;;; Code:
  25
  26 (require 'smime)
  27 (require 'mml2015)
  28 (eval-when-compile (require 'cl))
  29
  30 (defvar mml-sign-alist
  31   '(("smime"     mml-smime-sign-buffer     mml-secure-part-smime-sign)
  32     ("pgpmime"   mml-pgpmime-sign-buffer   list))
  33   "Alist of MIME signer functions.")
  34
  35 (defvar mml-default-sign-method (caar mml-sign-alist)
  36   "Default sign method.")
  37
  38 (defvar mml-encrypt-alist
  39   '(("smime"     mml-smime-encrypt-buffer mml-secure-part-smime-encrypt)
  40     ("pgpmime"   mml-pgpmime-encrypt-buffer   list))
  41   "Alist of MIME encryption functions.")
  42
  43 (defvar mml-default-encrypt-method (caar mml-encrypt-alist)
  44   "Default encryption method.")
  45
  46 ;;; Security functions
  47
  48 (defun mml-smime-sign-buffer (cont)
  49   (or (smime-sign-buffer (cdr (assq 'keyfile cont)))
  50       (error "Signing failed... inspect message logs for errors")))
  51
  52 (defun mml-smime-encrypt-buffer (cont)
  53   (or (smime-encrypt-buffer (list (cdr (assq 'certfile cont))))
  54       (error "Encryption failed... inspect message logs for errors")))
  55
  56 (defun mml-pgpmime-sign-buffer (cont)
  57   (or (mml2015-mailcrypt-sign cont)
  58       (error "Signing failed... inspect message logs for errors")))
  59
  60 (defun mml-pgpmime-encrypt-buffer (cont)
  61   (or (mml2015-mailcrypt-encrypt cont)
  62       (error "Encryption failed... inspect message logs for errors")))
  63
  64 (defun mml-secure-part-smime-sign ()
  65   (when (null smime-keys)
  66     (customize-variable 'smime-keys)
  67     (error "No S/MIME keys configured, use customize to add your key"))
  68   (list 'keyfile
  69         (if (= (length smime-keys) 1)
  70             (cadar smime-keys)
  71           (or (let ((from (cadr (funcall gnus-extract-address-components
  72                                          (or (save-excursion
  73                                                (save-restriction
  74                                                  (message-narrow-to-headers)
  75                                                  (message-fetch-field "from")))
  76                                              "")))))
  77                 (and from (smime-get-key-by-email from)))
  78               (smime-get-key-by-email
  79                (completing-read "Sign this part with what signature? "
  80                                 smime-keys nil nil
  81                                 (and (listp (car-safe smime-keys))
  82                                      (caar smime-keys))))))))
  83
  84 (defun mml-secure-part-smime-encrypt-by-file ()
  85   (ignore-errors
  86     (list 'certfile (read-file-name
  87                      "File with recipient's S/MIME certificate: "
  88                      smime-certificate-directory nil t ""))))
  89
  90 (defcustom mml-secure-dns-server ""
  91   "DNS server to query certificates from."
  92   :type 'string)
  93
  94 (defun mml-secure-part-smime-encrypt-by-dns ()
  95   ;; todo: deal with multiple recipients better
  96   (let* ((file (make-temp-name (expand-file-name "mml." mm-tmp-directory)))
  97          (buf (create-file-buffer file))
  98          result who bad)
  99     (condition-case ()
 100         (while (not result)
 101           (setq who (read-from-minibuffer
 102                      (format "%sLookup certificate for: " (or bad ""))
 103                      (cadr (funcall gnus-extract-address-components
 104                                     (or (save-excursion
 105                                           (save-restriction
 106                                             (message-narrow-to-headers)
 107                                             (message-fetch-field "to")))
 108                                         "")))))
 109           (if (eq (call-process "dnscert" nil buf nil who
 110                                 mml-secure-dns-server)
 111                   0)
 112               (with-current-buffer buf
 113                 (write-region (point-min) (point-max) file)
 114                 (setq result (list 'certfile file)))
 115             (setq bad (format "`%s' not found. " who))))
 116       (quit))
 117     (kill-buffer buf)
 118     result))
 119
 120 (defun mml-secure-part-smime-encrypt ()
 121   ;; todo: add ldap support (xemacs ldap api?)
 122   ;; todo: try dns/ldap automatically first, before prompting user
 123   (let (certs done)
 124     (while (not done)
 125       (ecase (read (gnus-completing-read "dns" "Fetch certificate from"
 126                                          '(("dns") ("file")) nil t))
 127         (dns (setq certs (append certs
 128                                  (mml-secure-part-smime-encrypt-by-dns))))
 129         (file (setq certs (append certs
 130                                   (mml-secure-part-smime-encrypt-by-file)))))
 131       (setq done (not (y-or-n-p "Add more recipients? "))))
 132     certs))
 133
 134 (defun mml-secure-part (method &optional sign)
 135   (save-excursion
 136     (let ((tags (funcall (nth 2 (assoc method (if sign mml-sign-alist
 137                                                 mml-encrypt-alist))))))
 138       (cond ((re-search-backward
 139               "<#\\(multipart\\|part\\|external\\|mml\\)" nil t)
 140              (goto-char (match-end 0))
 141              (insert (if sign " sign=" " encrypt=") method)
 142              (while tags
 143                (let ((key (pop tags))
 144                      (value (pop tags)))
 145                  (when value
 146                    ;; Quote VALUE if it contains suspicious characters.
 147                    (when (string-match "[\"'\\~/*;() \t\n]" value)
 148                      (setq value (prin1-to-string value)))
 149                    (insert (format " %s=%s" key value))))))
 150             ((or (re-search-backward
 151                   (concat "^" (regexp-quote mail-header-separator) "\n") nil t)
 152                  (re-search-forward
 153                   (concat "^" (regexp-quote mail-header-separator) "\n") nil t))
 154              (goto-char (match-end 0))
 155              (apply 'mml-insert-tag 'part (cons (if sign 'sign 'encrypt)
 156                                                 (cons method tags))))
 157             (t (error "Can't find where this part begin"))))))
 158
 159 (defun mml-secure-sign-pgpmime ()
 160   "Add MML tags to PGP/MIME sign this MML part."
 161   (interactive)
 162   (mml-secure-part "pgpmime" 'sign))
 163
 164 (defun mml-secure-sign-smime ()
 165   "Add MML tags to S/MIME sign this MML part."
 166   (interactive)
 167   (mml-secure-part "smime" 'sign))
 168
 169 (defun mml-secure-encrypt-pgpmime ()
 170   "Add MML tags to PGP/MIME encrypt this MML part."
 171   (interactive)
 172   (mml-secure-part "pgpmime"))
 173
 174 (defun mml-secure-encrypt-smime ()
 175   "Add MML tags to S/MIME encrypt this MML part."
 176   (interactive)
 177   (mml-secure-part "smime"))
 178
 179 (provide 'mml-sec)
 180
 181 ;;; mml-sec.el ends here