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   (let (certnames certfiles tmp file tmpfiles)
  54     (while (setq tmp (pop cont))
  55       (if (and (consp tmp) (eq (car tmp) 'certfile))
  56           (push (cdr tmp) certnames)))
  57     (while (setq tmp (pop certnames))
  58       (if (not (and (not (file-exists-p tmp))
  59                     (get-buffer tmp)))
  60           (push tmp certfiles)
  61         (setq file (make-temp-name 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         (while (setq tmp (pop tmpfiles))
  68           (delete-file tmp))
  69       (while (setq tmp (pop tmpfiles))
  70         (delete-file tmp))
  71       (error "Encryption failed... inspect message logs for errors"))))
  72
  73 (defun mml-pgpmime-sign-buffer (cont)
  74   (or (mml2015-sign cont)
  75       (error "Signing failed... inspect message logs for errors")))
  76
  77 (defun mml-pgpmime-encrypt-buffer (cont)
  78   (or (mml2015-encrypt cont)
  79       (error "Encryption failed... inspect message logs for errors")))
  80
  81 (defun mml-secure-part-smime-sign ()
  82   (when (null smime-keys)
  83     (customize-variable 'smime-keys)
  84     (error "No S/MIME keys configured, use customize to add your key"))
  85   (list 'keyfile
  86         (if (= (length smime-keys) 1)
  87             (cadar smime-keys)
  88           (or (let ((from (cadr (funcall gnus-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-secure-part-smime-encrypt-by-file ()
 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
 108 (defun mml-secure-part-smime-encrypt-by-dns ()
 109   ;; todo: deal with comma separated multiple recipients
 110   (let (result who bad cert)
 111     (condition-case ()
 112         (while (not result)
 113           (setq who (read-from-minibuffer
 114                      (format "%sLookup certificate for: " (or bad ""))
 115                      (cadr (funcall gnus-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-secure-part-smime-encrypt ()
 128   ;; todo: add ldap support (xemacs ldap api?)
 129   ;; todo: try dns/ldap automatically first, before prompting user
 130   (let (certs done)
 131     (while (not done)
 132       (ecase (read (gnus-completing-read "dns" "Fetch certificate from"
 133                                          '(("dns") ("file")) nil t))
 134         (dns (setq certs (append certs
 135                                  (mml-secure-part-smime-encrypt-by-dns))))
 136         (file (setq certs (append certs
 137                                   (mml-secure-part-smime-encrypt-by-file)))))
 138       (setq done (not (y-or-n-p "Add more recipients? "))))
 139     certs))
 140
 141 (defun mml-secure-part (method &optional sign)
 142   (save-excursion
 143     (let ((tags (funcall (nth 2 (assoc method (if sign mml-sign-alist
 144                                                 mml-encrypt-alist))))))
 145       (cond ((re-search-backward
 146               "<#\\(multipart\\|part\\|external\\|mml\\)" nil t)
 147              (goto-char (match-end 0))
 148              (insert (if sign " sign=" " encrypt=") method)
 149              (while tags
 150                (let ((key (pop tags))
 151                      (value (pop tags)))
 152                  (when value
 153                    ;; Quote VALUE if it contains suspicious characters.
 154                    (when (string-match "[\"'\\~/*;() \t\n]" value)
 155                      (setq value (prin1-to-string value)))
 156                    (insert (format " %s=%s" key value))))))
 157             ((or (re-search-backward
 158                   (concat "^" (regexp-quote mail-header-separator) "\n") nil t)
 159                  (re-search-forward
 160                   (concat "^" (regexp-quote mail-header-separator) "\n") nil t))
 161              (goto-char (match-end 0))
 162              (apply 'mml-insert-tag 'part (cons (if sign 'sign 'encrypt)
 163                                                 (cons method tags))))
 164             (t (error "Can't find where this part begin"))))))
 165
 166 (defun mml-secure-sign-pgpmime ()
 167   "Add MML tags to PGP/MIME sign this MML part."
 168   (interactive)
 169   (mml-secure-part "pgpmime" 'sign))
 170
 171 (defun mml-secure-sign-smime ()
 172   "Add MML tags to S/MIME sign this MML part."
 173   (interactive)
 174   (mml-secure-part "smime" 'sign))
 175
 176 (defun mml-secure-encrypt-pgpmime ()
 177   "Add MML tags to PGP/MIME encrypt this MML part."
 178   (interactive)
 179   (mml-secure-part "pgpmime"))
 180
 181 (defun mml-secure-encrypt-smime ()
 182   "Add MML tags to S/MIME encrypt this MML part."
 183   (interactive)
 184   (mml-secure-part "smime"))
 185
 186 (provide 'mml-sec)
 187
 188 ;;; mml-sec.el ends here