1 ;;; mml-sec.el --- A package with security functions for MML documents
2 ;; Copyright (C) 2000 Free Software Foundation, Inc.
4 ;; Author: Simon Josefsson <simon@josefsson.org>
5 ;; This file is not part of GNU Emacs, but the same permissions apply.
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)
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.
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.
28 (eval-when-compile (require 'cl))
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.")
35 (defvar mml-default-sign-method (caar mml-sign-alist)
36 "Default sign method.")
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.")
43 (defvar mml-default-encrypt-method (caar mml-encrypt-alist)
44 "Default encryption method.")
46 ;;; Security functions
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")))
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))
61 (setq file (make-temp-name mm-tmp-directory))
62 (with-current-buffer tmp
63 (write-region (point-min) (point-max) file))
65 (push file tmpfiles)))
66 (if (smime-encrypt-buffer certfiles)
67 (while (setq tmp (pop tmpfiles))
69 (while (setq tmp (pop tmpfiles))
71 (error "Encryption failed... inspect message logs for errors"))))
73 (defun mml-pgpmime-sign-buffer (cont)
74 (or (mml2015-sign cont)
75 (error "Signing failed... inspect message logs for errors")))
77 (defun mml-pgpmime-encrypt-buffer (cont)
78 (or (mml2015-encrypt cont)
79 (error "Encryption failed... inspect message logs for errors")))
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"))
86 (if (= (length smime-keys) 1)
88 (or (let ((from (cadr (funcall gnus-extract-address-components
91 (message-narrow-to-headers)
92 (message-fetch-field "from")))
94 (and from (smime-get-key-by-email from)))
95 (smime-get-key-by-email
96 (completing-read "Sign this part with what signature? "
98 (and (listp (car-safe smime-keys))
99 (caar smime-keys))))))))
101 (defun mml-secure-part-smime-encrypt-by-file ()
103 (list 'certfile (read-file-name
104 "File with recipient's S/MIME certificate: "
105 smime-certificate-directory nil t ""))))
108 (defun mml-secure-part-smime-encrypt-by-dns ()
109 ;; todo: deal with comma separated multiple recipients
110 (let (result who bad cert)
113 (setq who (read-from-minibuffer
114 (format "%sLookup certificate for: " (or bad ""))
115 (cadr (funcall gnus-extract-address-components
118 (message-narrow-to-headers)
119 (message-fetch-field "to")))
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))))
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
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? "))))
141 (defun mml-secure-part (method &optional sign)
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)
150 (let ((key (pop tags))
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)
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"))))))
166 (defun mml-secure-sign-pgpmime ()
167 "Add MML tags to PGP/MIME sign this MML part."
169 (mml-secure-part "pgpmime" 'sign))
171 (defun mml-secure-sign-smime ()
172 "Add MML tags to S/MIME sign this MML part."
174 (mml-secure-part "smime" 'sign))
176 (defun mml-secure-encrypt-pgpmime ()
177 "Add MML tags to PGP/MIME encrypt this MML part."
179 (mml-secure-part "pgpmime"))
181 (defun mml-secure-encrypt-smime ()
182 "Add MML tags to S/MIME encrypt this MML part."
184 (mml-secure-part "smime"))
188 ;;; mml-sec.el ends here