SXEmacs tweaks
[gnus] / lisp / mml2015.el
1 ;;; mml2015.el --- MIME Security with Pretty Good Privacy (PGP)
2
3 ;; Copyright (C) 2000-2016 Free Software Foundation, Inc.
4
5 ;; Author: Shenghuo Zhu <zsh@cs.rochester.edu>
6 ;; Keywords: PGP MIME MML
7
8 ;; This file is part of GNU Emacs.
9
10 ;; GNU Emacs is free software: you can redistribute it and/or modify
11 ;; it under the terms of the GNU General Public License as published by
12 ;; the Free Software Foundation, either version 3 of the License, or
13 ;; (at your option) any later version.
14
15 ;; GNU Emacs is distributed in the hope that it will be useful,
16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
18 ;; GNU General Public License for more details.
19
20 ;; You should have received a copy of the GNU General Public License
21 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
22
23 ;;; Commentary:
24
25 ;; RFC 2015 is updated by RFC 3156, this file should be compatible
26 ;; with both.
27
28 ;;; Code:
29
30 (eval-and-compile
31   (if (locate-library "password-cache")
32       (require 'password-cache)
33     (require 'password)))
34
35 (eval-when-compile (require 'cl))
36 (require 'mm-decode)
37 (require 'mm-util)
38 (require 'mml)
39 (require 'mml-sec)
40
41 (defvar mc-pgp-always-sign)
42
43 (declare-function epg-check-configuration "ext:epg-config"
44                   (config &optional minimum-version))
45 (declare-function epg-configuration "ext:epg-config" ())
46
47 ;; Maybe this should be in eg mml-sec.el (and have a different name).
48 ;; Then mml1991 would not need to require mml2015, and mml1991-use
49 ;; could be removed.
50 (defvar mml2015-use (or
51                      (progn
52                        (ignore-errors (require 'epg-config))
53                        (and (fboundp 'epg-check-configuration)
54                            'epg))
55                      (progn
56                        (let ((abs-file (locate-library "pgg")))
57                          ;; Don't load PGG if it is marked as obsolete
58                          ;; (Emacs 24).
59                          (when (and abs-file
60                                     (not (string-match "/obsolete/[^/]*\\'"
61                                                        abs-file)))
62                            (ignore-errors (require 'pgg))
63                            (and (fboundp 'pgg-sign-region)
64                                 'pgg))))
65                      (progn (ignore-errors
66                               (load "mc-toplev"))
67                             (and (fboundp 'mc-encrypt-generic)
68                                  (fboundp 'mc-sign-generic)
69                                  (fboundp 'mc-cleanup-recipient-headers)
70                                  'mailcrypt)))
71   "The package used for PGP/MIME.
72 Valid packages include `epg', `pgg' and `mailcrypt'.")
73
74 ;; Something is not RFC2015.
75 (defvar mml2015-function-alist
76   '((mailcrypt mml2015-mailcrypt-sign
77                mml2015-mailcrypt-encrypt
78                mml2015-mailcrypt-verify
79                mml2015-mailcrypt-decrypt
80                mml2015-mailcrypt-clear-verify
81                mml2015-mailcrypt-clear-decrypt)
82     (pgg mml2015-pgg-sign
83          mml2015-pgg-encrypt
84          mml2015-pgg-verify
85          mml2015-pgg-decrypt
86          mml2015-pgg-clear-verify
87          mml2015-pgg-clear-decrypt)
88     (epg mml2015-epg-sign
89          mml2015-epg-encrypt
90          mml2015-epg-verify
91          mml2015-epg-decrypt
92          mml2015-epg-clear-verify
93          mml2015-epg-clear-decrypt))
94   "Alist of PGP/MIME functions.")
95
96 (defvar mml2015-result-buffer nil)
97
98 (defcustom mml2015-unabbrev-trust-alist
99   '(("TRUST_UNDEFINED" . nil)
100     ("TRUST_NEVER"     . nil)
101     ("TRUST_MARGINAL"  . t)
102     ("TRUST_FULLY"     . t)
103     ("TRUST_ULTIMATE"  . t))
104   "Map GnuPG trust output values to a boolean saying if you trust the key."
105   :version "22.1"
106   :group 'mime-security
107   :type '(repeat (cons (regexp :tag "GnuPG output regexp")
108                        (boolean :tag "Trust key"))))
109
110 (defcustom mml2015-cache-passphrase mml-secure-cache-passphrase
111   "If t, cache passphrase."
112   :group 'mime-security
113   :type 'boolean)
114 (make-obsolete-variable 'mml2015-cache-passphrase
115                         'mml-secure-cache-passphrase
116                         "25.1")
117
118 (defcustom mml2015-passphrase-cache-expiry mml-secure-passphrase-cache-expiry
119   "How many seconds the passphrase is cached.
120 Whether the passphrase is cached at all is controlled by
121 `mml2015-cache-passphrase'."
122   :group 'mime-security
123   :type 'integer)
124 (make-obsolete-variable 'mml2015-passphrase-cache-expiry
125                         'mml-secure-passphrase-cache-expiry
126                         "25.1")
127
128 (defcustom mml2015-signers nil
129   "A list of your own key ID(s) which will be used to sign a message.
130 If set, it overrides the setting of `mml2015-sign-with-sender'."
131   :group 'mime-security
132   :type '(repeat (string :tag "Key ID")))
133
134 (defcustom mml2015-sign-with-sender nil
135   "If t, use message sender so find a key to sign with."
136   :group 'mime-security
137   :type 'boolean
138   :version "24.1")
139
140 (defcustom mml2015-encrypt-to-self nil
141   "If t, add your own key ID to recipient list when encryption."
142   :group 'mime-security
143   :type 'boolean)
144
145 (defcustom mml2015-always-trust t
146   "If t, GnuPG skip key validation on encryption."
147   :group 'mime-security
148   :type 'boolean)
149
150 (defcustom mml2015-maximum-key-image-dimension 64
151   "The maximum dimension (width or height) of any key images."
152   :version "24.4"
153   :group 'mime-security
154   :type 'integer)
155
156 (defcustom mml2015-display-key-image t
157   "If t, try to display key images."
158   :version "24.5"
159   :group 'mime-security
160   :type 'boolean)
161
162 ;; Extract plaintext from cleartext signature.  IMO, this kind of task
163 ;; should be done by GnuPG rather than Elisp, but older PGP backends
164 ;; (such as Mailcrypt, and PGG) discard the output from GnuPG.
165 (defun mml2015-extract-cleartext-signature ()
166   ;; Daiki Ueno in
167   ;; <54a15d860801080142l70b95d7dkac4bf51a86196011@mail.gmail.com>: ``I still
168   ;; believe that the right way is to use the plaintext output from GnuPG as
169   ;; it is, and mml2015-extract-cleartext-signature is just a kludge for
170   ;; misdesigned libraries like PGG, which have no ability to do that.  So, I
171   ;; think it should not have descriptive documentation.''
172   ;;
173   ;; This function doesn't handle NotDashEscaped correctly.  EasyPG handles it
174   ;; correctly.
175   ;; http://thread.gmane.org/gmane.emacs.gnus.general/66062/focus=66082
176   ;; http://thread.gmane.org/gmane.emacs.gnus.general/65087/focus=65109
177   (goto-char (point-min))
178   (forward-line)
179   ;; We need to be careful not to strip beyond the armor headers.
180   ;; Previously, an attacker could replace the text inside our
181   ;; markup with trailing garbage by injecting whitespace into the
182   ;; message.
183   (while (looking-at "Hash:")           ; The only header allowed in cleartext
184     (forward-line))                     ; signatures according to RFC2440.
185   (when (looking-at "[\t ]*$")
186     (forward-line))
187   (delete-region (point-min) (point))
188   (if (re-search-forward "^-----BEGIN PGP SIGNATURE-----" nil t)
189       (delete-region (match-beginning 0) (point-max)))
190   (goto-char (point-min))
191   (while (re-search-forward "^- " nil t)
192     (replace-match "" t t)
193     (forward-line 1)))
194
195 ;;; mailcrypt wrapper
196
197 (autoload 'mailcrypt-decrypt "mailcrypt")
198 (autoload 'mailcrypt-verify "mailcrypt")
199 (autoload 'mc-pgp-always-sign "mailcrypt")
200 (autoload 'mc-encrypt-generic "mc-toplev")
201 (autoload 'mc-cleanup-recipient-headers "mc-toplev")
202 (autoload 'mc-sign-generic "mc-toplev")
203
204 (defvar mml2015-decrypt-function 'mailcrypt-decrypt)
205 (defvar mml2015-verify-function 'mailcrypt-verify)
206
207 (defun mml2015-format-error (err)
208   (if (stringp (cadr err))
209       (cadr err)
210     (format "%S" (cdr err))))
211
212 (defun mml2015-mailcrypt-decrypt (handle ctl)
213   (catch 'error
214     (let (child handles result)
215       (unless (setq child (mm-find-part-by-type
216                            (cdr handle)
217                            "application/octet-stream" nil t))
218         (mm-set-handle-multipart-parameter
219          mm-security-handle 'gnus-info "Corrupted")
220         (throw 'error handle))
221       (with-temp-buffer
222         (mm-insert-part child)
223         (setq result
224               (condition-case err
225                   (funcall mml2015-decrypt-function)
226                 (error
227                  (mm-set-handle-multipart-parameter
228                   mm-security-handle 'gnus-details (mml2015-format-error err))
229                  nil)
230                 (quit
231                  (mm-set-handle-multipart-parameter
232                   mm-security-handle 'gnus-details "Quit.")
233                  nil)))
234         (unless (car result)
235           (mm-set-handle-multipart-parameter
236            mm-security-handle 'gnus-info "Failed")
237           (throw 'error handle))
238         (setq handles (mm-dissect-buffer t)))
239       (mm-destroy-parts handle)
240       (mm-set-handle-multipart-parameter
241        mm-security-handle 'gnus-info
242        (concat "OK"
243                (let ((sig (with-current-buffer mml2015-result-buffer
244                             (mml2015-gpg-extract-signature-details))))
245                  (concat ", Signer: " sig))))
246       (if (listp (car handles))
247           handles
248         (list handles)))))
249
250 (defun mml2015-gpg-pretty-print-fpr (fingerprint)
251   (let* ((result "")
252          (fpr-length (string-width fingerprint))
253          (n-slice 0)
254          slice)
255     (setq fingerprint (string-to-list fingerprint))
256     (while fingerprint
257       (setq fpr-length (- fpr-length 4))
258       (setq slice (butlast fingerprint fpr-length))
259       (setq fingerprint (nthcdr 4 fingerprint))
260       (setq n-slice (1+ n-slice))
261       (setq result
262             (concat
263              result
264              (case n-slice
265                (1  slice)
266                (otherwise (concat " " slice))))))
267     result))
268
269 (defun mml2015-gpg-extract-signature-details ()
270   (goto-char (point-min))
271   (let* ((expired (re-search-forward
272                    "^\\[GNUPG:\\] SIGEXPIRED$"
273                    nil t))
274          (signer (and (re-search-forward
275                        "^\\[GNUPG:\\] GOODSIG \\([0-9A-Za-z]*\\) \\(.*\\)$"
276                        nil t)
277                       (cons (match-string 1) (match-string 2))))
278          (fprint (and (re-search-forward
279                        "^\\[GNUPG:\\] VALIDSIG \\([0-9a-zA-Z]*\\) "
280                        nil t)
281                       (match-string 1)))
282          (trust  (and (re-search-forward
283                        "^\\[GNUPG:\\] \\(TRUST_.*\\)$"
284                        nil t)
285                       (match-string 1)))
286          (trust-good-enough-p
287           (cdr (assoc trust mml2015-unabbrev-trust-alist))))
288     (cond ((and signer fprint)
289            (concat (cdr signer)
290                    (unless trust-good-enough-p
291                      (concat "\nUntrusted, Fingerprint: "
292                              (mml2015-gpg-pretty-print-fpr fprint)))
293                    (when expired
294                      (format "\nWARNING: Signature from expired key (%s)"
295                              (car signer)))))
296           ((re-search-forward
297             "^\\(gpg: \\)?Good signature from \"\\(.*\\)\"$" nil t)
298            (match-string 2))
299           (t
300            "From unknown user"))))
301
302 (defun mml2015-mailcrypt-clear-decrypt ()
303   (let (result)
304     (setq result
305           (condition-case err
306               (funcall mml2015-decrypt-function)
307             (error
308              (mm-set-handle-multipart-parameter
309               mm-security-handle 'gnus-details (mml2015-format-error err))
310              nil)
311             (quit
312              (mm-set-handle-multipart-parameter
313               mm-security-handle 'gnus-details "Quit.")
314              nil)))
315     (if (car result)
316         (mm-set-handle-multipart-parameter
317          mm-security-handle 'gnus-info "OK")
318       (mm-set-handle-multipart-parameter
319        mm-security-handle 'gnus-info "Failed"))))
320
321 (defun mml2015-fix-micalg (alg)
322   (and alg
323        ;; Mutt/1.2.5i has seen sending micalg=php-sha1
324        (upcase (if (string-match "^p[gh]p-" alg)
325                    (substring alg (match-end 0))
326                  alg))))
327
328 (defun mml2015-mailcrypt-verify (handle ctl)
329   (catch 'error
330     (let (part)
331       (unless (setq part (mm-find-raw-part-by-type
332                           ctl (or (mm-handle-multipart-ctl-parameter
333                                    ctl 'protocol)
334                                   "application/pgp-signature")
335                           t))
336         (mm-set-handle-multipart-parameter
337          mm-security-handle 'gnus-info "Corrupted")
338         (throw 'error handle))
339       (with-temp-buffer
340         (insert "-----BEGIN PGP SIGNED MESSAGE-----\n")
341         (insert (format "Hash: %s\n\n"
342                         (or (mml2015-fix-micalg
343                              (mm-handle-multipart-ctl-parameter
344                               ctl 'micalg))
345                             "SHA1")))
346         (save-restriction
347           (narrow-to-region (point) (point))
348           (insert part "\n")
349           (goto-char (point-min))
350           (while (not (eobp))
351             (if (looking-at "^-")
352                 (insert "- "))
353             (forward-line)))
354         (unless (setq part (mm-find-part-by-type
355                             (cdr handle) "application/pgp-signature" nil t))
356           (mm-set-handle-multipart-parameter
357            mm-security-handle 'gnus-info "Corrupted")
358           (throw 'error handle))
359         (save-restriction
360           (narrow-to-region (point) (point))
361           (mm-insert-part part)
362           (goto-char (point-min))
363           (if (re-search-forward "^-----BEGIN PGP [^-]+-----\r?$" nil t)
364               (replace-match "-----BEGIN PGP SIGNATURE-----" t t))
365           (if (re-search-forward "^-----END PGP [^-]+-----\r?$" nil t)
366               (replace-match "-----END PGP SIGNATURE-----" t t)))
367         (let ((mc-gpg-debug-buffer (get-buffer-create " *gnus gpg debug*")))
368           (unless (condition-case err
369                       (prog1
370                           (funcall mml2015-verify-function)
371                         (if (get-buffer " *mailcrypt stderr temp")
372                             (mm-set-handle-multipart-parameter
373                              mm-security-handle 'gnus-details
374                              (with-current-buffer " *mailcrypt stderr temp"
375                                (buffer-string))))
376                         (if (get-buffer " *mailcrypt stdout temp")
377                             (kill-buffer " *mailcrypt stdout temp"))
378                         (if (get-buffer " *mailcrypt stderr temp")
379                             (kill-buffer " *mailcrypt stderr temp"))
380                         (if (get-buffer " *mailcrypt status temp")
381                             (kill-buffer " *mailcrypt status temp"))
382                         (if (get-buffer mc-gpg-debug-buffer)
383                             (kill-buffer mc-gpg-debug-buffer)))
384                     (error
385                      (mm-set-handle-multipart-parameter
386                       mm-security-handle 'gnus-details (mml2015-format-error err))
387                      nil)
388                     (quit
389                      (mm-set-handle-multipart-parameter
390                       mm-security-handle 'gnus-details "Quit.")
391                      nil))
392             (mm-set-handle-multipart-parameter
393              mm-security-handle 'gnus-info "Failed")
394             (throw 'error handle))))
395       (mm-set-handle-multipart-parameter
396        mm-security-handle 'gnus-info "OK")
397       handle)))
398
399 (defun mml2015-mailcrypt-clear-verify ()
400   (let ((mc-gpg-debug-buffer (get-buffer-create " *gnus gpg debug*")))
401     (if (condition-case err
402             (prog1
403                 (funcall mml2015-verify-function)
404               (if (get-buffer " *mailcrypt stderr temp")
405                   (mm-set-handle-multipart-parameter
406                    mm-security-handle 'gnus-details
407                    (with-current-buffer " *mailcrypt stderr temp"
408                      (buffer-string))))
409               (if (get-buffer " *mailcrypt stdout temp")
410                   (kill-buffer " *mailcrypt stdout temp"))
411               (if (get-buffer " *mailcrypt stderr temp")
412                   (kill-buffer " *mailcrypt stderr temp"))
413               (if (get-buffer " *mailcrypt status temp")
414                   (kill-buffer " *mailcrypt status temp"))
415               (if (get-buffer mc-gpg-debug-buffer)
416                   (kill-buffer mc-gpg-debug-buffer)))
417           (error
418            (mm-set-handle-multipart-parameter
419             mm-security-handle 'gnus-details (mml2015-format-error err))
420            nil)
421           (quit
422            (mm-set-handle-multipart-parameter
423             mm-security-handle 'gnus-details "Quit.")
424            nil))
425         (mm-set-handle-multipart-parameter
426          mm-security-handle 'gnus-info "OK")
427       (mm-set-handle-multipart-parameter
428        mm-security-handle 'gnus-info "Failed")))
429   (mml2015-extract-cleartext-signature))
430
431 (defun mml2015-mailcrypt-sign (cont)
432   (mc-sign-generic (message-options-get 'message-sender)
433                    nil nil nil nil)
434   (let ((boundary (mml-compute-boundary cont))
435         hash point)
436     (goto-char (point-min))
437     (unless (re-search-forward "^-----BEGIN PGP SIGNED MESSAGE-----\r?$" nil t)
438       (error "Cannot find signed begin line"))
439     (goto-char (match-beginning 0))
440     (forward-line 1)
441     (unless (looking-at "Hash:[ \t]*\\([a-zA-Z0-9]+\\)")
442       (error "Cannot not find PGP hash"))
443     (setq hash (match-string 1))
444     (unless (re-search-forward "^$" nil t)
445       (error "Cannot not find PGP message"))
446     (forward-line 1)
447     (delete-region (point-min) (point))
448     (insert (format "Content-Type: multipart/signed; boundary=\"%s\";\n"
449                     boundary))
450     (insert (format "\tmicalg=pgp-%s; protocol=\"application/pgp-signature\"\n"
451                     (downcase hash)))
452     (insert (format "\n--%s\n" boundary))
453     (setq point (point))
454     (goto-char (point-max))
455     (unless (re-search-backward "^-----END PGP SIGNATURE-----\r?$" nil t)
456       (error "Cannot find signature part"))
457     (replace-match "-----END PGP MESSAGE-----" t t)
458     (goto-char (match-beginning 0))
459     (unless (re-search-backward "^-----BEGIN PGP SIGNATURE-----\r?$"
460                                 nil t)
461       (error "Cannot find signature part"))
462     (replace-match "-----BEGIN PGP MESSAGE-----" t t)
463     (goto-char (match-beginning 0))
464     (save-restriction
465       (narrow-to-region point (point))
466       (goto-char point)
467       (while (re-search-forward "^- -" nil t)
468         (replace-match "-" t t))
469       (goto-char (point-max)))
470     (insert (format "--%s\n" boundary))
471     (insert "Content-Type: application/pgp-signature\n\n")
472     (goto-char (point-max))
473     (insert (format "--%s--\n" boundary))
474     (goto-char (point-max))))
475
476 ;; We require mm-decode, which requires mm-bodies, which autoloads
477 ;; message-options-get (!).
478 (declare-function message-options-set "message" (symbol value))
479
480 (defun mml2015-mailcrypt-encrypt (cont &optional sign)
481   (let ((mc-pgp-always-sign
482          (or mc-pgp-always-sign
483              sign
484              (eq t (or (message-options-get 'message-sign-encrypt)
485                        (message-options-set
486                         'message-sign-encrypt
487                         (or (y-or-n-p "Sign the message? ")
488                             'not))))
489              'never)))
490     (mm-with-unibyte-current-buffer
491       (mc-encrypt-generic
492        (or (message-options-get 'message-recipients)
493            (message-options-set 'message-recipients
494                               (mc-cleanup-recipient-headers
495                                (read-string "Recipients: "))))
496        nil nil nil
497        (message-options-get 'message-sender))))
498   (goto-char (point-min))
499   (unless (looking-at "-----BEGIN PGP MESSAGE-----")
500     (error "Fail to encrypt the message"))
501   (let ((boundary (mml-compute-boundary cont)))
502     (insert (format "Content-Type: multipart/encrypted; boundary=\"%s\";\n"
503                     boundary))
504     (insert "\tprotocol=\"application/pgp-encrypted\"\n\n")
505     (insert (format "--%s\n" boundary))
506     (insert "Content-Type: application/pgp-encrypted\n\n")
507     (insert "Version: 1\n\n")
508     (insert (format "--%s\n" boundary))
509     (insert "Content-Type: application/octet-stream\n\n")
510     (goto-char (point-max))
511     (insert (format "--%s--\n" boundary))
512     (goto-char (point-max))))
513
514 ;;; pgg wrapper
515
516 (defvar pgg-default-user-id)
517 (defvar pgg-errors-buffer)
518 (defvar pgg-output-buffer)
519
520 (autoload 'pgg-decrypt-region "pgg")
521 (autoload 'pgg-verify-region "pgg")
522 (autoload 'pgg-sign-region "pgg")
523 (autoload 'pgg-encrypt-region "pgg")
524 (autoload 'pgg-parse-armor "pgg-parse")
525
526 (defun mml2015-pgg-decrypt (handle ctl)
527   (catch 'error
528     (let ((pgg-errors-buffer mml2015-result-buffer)
529           child handles result decrypt-status)
530       (unless (setq child (mm-find-part-by-type
531                            (cdr handle)
532                            "application/octet-stream" nil t))
533         (mm-set-handle-multipart-parameter
534          mm-security-handle 'gnus-info "Corrupted")
535         (throw 'error handle))
536       (with-temp-buffer
537         (mm-insert-part child)
538         (if (condition-case err
539                 (prog1
540                     (pgg-decrypt-region (point-min) (point-max))
541                   (setq decrypt-status
542                         (with-current-buffer mml2015-result-buffer
543                           (buffer-string)))
544                   (mm-set-handle-multipart-parameter
545                    mm-security-handle 'gnus-details
546                    decrypt-status))
547               (error
548                (mm-set-handle-multipart-parameter
549                 mm-security-handle 'gnus-details (mml2015-format-error err))
550                nil)
551               (quit
552                (mm-set-handle-multipart-parameter
553                 mm-security-handle 'gnus-details "Quit.")
554                nil))
555             (with-current-buffer pgg-output-buffer
556               (goto-char (point-min))
557               (while (search-forward "\r\n" nil t)
558                 (replace-match "\n" t t))
559               (setq handles (mm-dissect-buffer t))
560               (mm-destroy-parts handle)
561               (mm-set-handle-multipart-parameter
562                mm-security-handle 'gnus-info "OK")
563               (mm-set-handle-multipart-parameter
564                mm-security-handle 'gnus-details
565                (concat decrypt-status
566                        (when (stringp (car handles))
567                          "\n" (mm-handle-multipart-ctl-parameter
568                                handles 'gnus-details))))
569               (if (listp (car handles))
570                   handles
571                 (list handles)))
572           (mm-set-handle-multipart-parameter
573            mm-security-handle 'gnus-info "Failed")
574           (throw 'error handle))))))
575
576 (defun mml2015-pgg-clear-decrypt ()
577   (let ((pgg-errors-buffer mml2015-result-buffer))
578     (if (prog1
579             (pgg-decrypt-region (point-min) (point-max))
580           (mm-set-handle-multipart-parameter
581            mm-security-handle 'gnus-details
582            (with-current-buffer mml2015-result-buffer
583              (buffer-string))))
584         (progn
585           (erase-buffer)
586           ;; Treat data which pgg returns as a unibyte string.
587           (mm-disable-multibyte)
588           (insert-buffer-substring pgg-output-buffer)
589           (goto-char (point-min))
590           (while (search-forward "\r\n" nil t)
591             (replace-match "\n" t t))
592           (mm-set-handle-multipart-parameter
593            mm-security-handle 'gnus-info "OK"))
594       (mm-set-handle-multipart-parameter
595        mm-security-handle 'gnus-info "Failed"))))
596
597 (defun mml2015-pgg-verify (handle ctl)
598   (let ((pgg-errors-buffer mml2015-result-buffer)
599         signature-file part signature)
600     (if (or (null (setq part (mm-find-raw-part-by-type
601                               ctl (or (mm-handle-multipart-ctl-parameter
602                                        ctl 'protocol)
603                                       "application/pgp-signature")
604                               t)))
605             (null (setq signature (mm-find-part-by-type
606                                    (cdr handle) "application/pgp-signature" nil t))))
607         (progn
608           (mm-set-handle-multipart-parameter
609            mm-security-handle 'gnus-info "Corrupted")
610           handle)
611       (with-temp-buffer
612         (insert part)
613         ;; Convert <LF> to <CR><LF> in signed text.  If --textmode is
614         ;; specified when signing, the conversion is not necessary.
615         (goto-char (point-min))
616         (end-of-line)
617         (while (not (eobp))
618           (unless (eq (char-before) ?\r)
619             (insert "\r"))
620           (forward-line)
621           (end-of-line))
622         (with-temp-file (setq signature-file (mm-make-temp-file "pgg"))
623           (mm-insert-part signature))
624         (if (condition-case err
625                 (prog1
626                     (pgg-verify-region (point-min) (point-max)
627                                        signature-file t)
628                   (goto-char (point-min))
629                   (while (search-forward "\r\n" nil t)
630                     (replace-match "\n" t t))
631                   (mm-set-handle-multipart-parameter
632                    mm-security-handle 'gnus-details
633                    (concat (with-current-buffer pgg-output-buffer
634                              (buffer-string))
635                            (with-current-buffer pgg-errors-buffer
636                              (buffer-string)))))
637               (error
638                (mm-set-handle-multipart-parameter
639                 mm-security-handle 'gnus-details (mml2015-format-error err))
640                nil)
641               (quit
642                (mm-set-handle-multipart-parameter
643                 mm-security-handle 'gnus-details "Quit.")
644                nil))
645             (progn
646               (delete-file signature-file)
647               (mm-set-handle-multipart-parameter
648                mm-security-handle 'gnus-info
649                (with-current-buffer pgg-errors-buffer
650                  (mml2015-gpg-extract-signature-details))))
651           (delete-file signature-file)
652           (mm-set-handle-multipart-parameter
653            mm-security-handle 'gnus-info "Failed")))))
654   handle)
655
656 (defun mml2015-pgg-clear-verify ()
657   (let ((pgg-errors-buffer mml2015-result-buffer)
658         (text (buffer-string))
659         (coding-system buffer-file-coding-system))
660     (if (condition-case err
661             (prog1
662                 (mm-with-unibyte-buffer
663                   (insert (mm-encode-coding-string text coding-system))
664                   (pgg-verify-region (point-min) (point-max) nil t))
665               (goto-char (point-min))
666               (while (search-forward "\r\n" nil t)
667                 (replace-match "\n" t t))
668               (mm-set-handle-multipart-parameter
669                mm-security-handle 'gnus-details
670                (concat (with-current-buffer pgg-output-buffer
671                          (buffer-string))
672                        (with-current-buffer pgg-errors-buffer
673                          (buffer-string)))))
674           (error
675            (mm-set-handle-multipart-parameter
676             mm-security-handle 'gnus-details (mml2015-format-error err))
677            nil)
678           (quit
679            (mm-set-handle-multipart-parameter
680             mm-security-handle 'gnus-details "Quit.")
681            nil))
682         (mm-set-handle-multipart-parameter
683          mm-security-handle 'gnus-info
684          (with-current-buffer pgg-errors-buffer
685            (mml2015-gpg-extract-signature-details)))
686       (mm-set-handle-multipart-parameter
687        mm-security-handle 'gnus-info "Failed")))
688   (mml2015-extract-cleartext-signature))
689
690 (defun mml2015-pgg-sign (cont)
691   (let ((pgg-errors-buffer mml2015-result-buffer)
692         (boundary (mml-compute-boundary cont))
693         (pgg-default-user-id (or (message-options-get 'mml-sender)
694                                  pgg-default-user-id))
695         (pgg-text-mode t)
696         entry)
697     (unless (pgg-sign-region (point-min) (point-max))
698       (pop-to-buffer mml2015-result-buffer)
699       (error "Sign error"))
700     (goto-char (point-min))
701     (insert (format "Content-Type: multipart/signed; boundary=\"%s\";\n"
702                     boundary))
703     (if (setq entry (assq 2 (pgg-parse-armor
704                              (with-current-buffer pgg-output-buffer
705                                (buffer-string)))))
706         (setq entry (assq 'hash-algorithm (cdr entry))))
707     (insert (format "\tmicalg=%s; "
708                     (if (cdr entry)
709                         (downcase (format "pgp-%s" (cdr entry)))
710                       "pgp-sha1")))
711     (insert "protocol=\"application/pgp-signature\"\n")
712     (insert (format "\n--%s\n" boundary))
713     (goto-char (point-max))
714     (insert (format "\n--%s\n" boundary))
715     (insert "Content-Type: application/pgp-signature\n\n")
716     (insert-buffer-substring pgg-output-buffer)
717     (goto-char (point-max))
718     (insert (format "--%s--\n" boundary))
719     (goto-char (point-max))))
720
721 (defun mml2015-pgg-encrypt (cont &optional sign)
722   (let ((pgg-errors-buffer mml2015-result-buffer)
723         (pgg-text-mode t)
724         (boundary (mml-compute-boundary cont)))
725     (unless (pgg-encrypt-region (point-min) (point-max)
726                                 (split-string
727                                  (or
728                                   (message-options-get 'message-recipients)
729                                   (message-options-set 'message-recipients
730                                                        (read-string "Recipients: ")))
731                                  "[ \f\t\n\r\v,]+")
732                                 sign)
733       (pop-to-buffer mml2015-result-buffer)
734       (error "Encrypt error"))
735     (delete-region (point-min) (point-max))
736     (goto-char (point-min))
737     (insert (format "Content-Type: multipart/encrypted; boundary=\"%s\";\n"
738                     boundary))
739     (insert "\tprotocol=\"application/pgp-encrypted\"\n\n")
740     (insert (format "--%s\n" boundary))
741     (insert "Content-Type: application/pgp-encrypted\n\n")
742     (insert "Version: 1\n\n")
743     (insert (format "--%s\n" boundary))
744     (insert "Content-Type: application/octet-stream\n\n")
745     (insert-buffer-substring pgg-output-buffer)
746     (goto-char (point-max))
747     (insert (format "--%s--\n" boundary))
748     (goto-char (point-max))))
749
750 ;;; epg wrapper
751
752 (defvar epg-user-id-alist)
753 (defvar epg-digest-algorithm-alist)
754 (defvar epg-gpg-program)
755 (defvar inhibit-redisplay)
756
757 (autoload 'epg-make-context "epg")
758 (autoload 'epg-context-set-armor "epg")
759 (autoload 'epg-context-set-textmode "epg")
760 (autoload 'epg-context-set-signers "epg")
761 (autoload 'epg-context-result-for "epg")
762 (autoload 'epg-new-signature-digest-algorithm "epg")
763 (autoload 'epg-list-keys "epg")
764 (autoload 'epg-decrypt-string "epg")
765 (autoload 'epg-verify-string "epg")
766 (autoload 'epg-sign-string "epg")
767 (autoload 'epg-encrypt-string "epg")
768 (autoload 'epg-passphrase-callback-function "epg")
769 (autoload 'epg-context-set-passphrase-callback "epg")
770 (autoload 'epg-key-sub-key-list "epg")
771 (autoload 'epg-sub-key-capability "epg")
772 (autoload 'epg-sub-key-validity "epg")
773 (autoload 'epg-sub-key-fingerprint "epg")
774 (autoload 'epg-signature-key-id "epg")
775 (autoload 'epg-signature-to-string "epg")
776 (autoload 'epg-key-user-id-list "epg")
777 (autoload 'epg-user-id-string "epg")
778 (autoload 'epg-user-id-validity "epg")
779 (autoload 'epg-configuration "epg-config")
780 (autoload 'epg-expand-group "epg-config")
781 (autoload 'epa-select-keys "epa")
782
783 (autoload 'gnus-create-image "gnus-ems")
784
785 (defun mml2015-epg-key-image (key-id)
786   "Return the image of a key, if any"
787   (with-temp-buffer
788     (mm-set-buffer-multibyte nil)
789     (let* ((coding-system-for-write 'binary)
790            (coding-system-for-read 'binary)
791            (data (shell-command-to-string
792                   (format "%s --list-options no-show-photos --attribute-fd 3 --list-keys %s 3>&1 >/dev/null 2>&1"
793                           (shell-quote-argument epg-gpg-program) key-id))))
794       (when (> (length data) 0)
795         (insert (substring data 16))
796         (condition-case nil
797             (gnus-create-image (buffer-string) nil t)
798           (error))))))
799
800 (autoload 'gnus-rescale-image "gnus-util")
801
802 (defun mml2015-epg-key-image-to-string (key-id)
803   "Return a string with the image of a key, if any"
804   (let ((key-image (mml2015-epg-key-image key-id)))
805     (if (not key-image)
806         ""
807       (condition-case error
808           (let ((result "  "))
809             (put-text-property
810              1 2 'display
811              (gnus-rescale-image key-image
812                                  (cons mml2015-maximum-key-image-dimension
813                                        mml2015-maximum-key-image-dimension))
814              result)
815             result)
816         (error "")))))
817
818 (defun mml2015-epg-signature-to-string (signature)
819   (concat (epg-signature-to-string signature)
820           (when mml2015-display-key-image
821             (mml2015-epg-key-image-to-string (epg-signature-key-id signature)))))
822
823 (defun mml2015-epg-verify-result-to-string (verify-result)
824   (mapconcat #'mml2015-epg-signature-to-string verify-result "\n"))
825
826 (defun mml2015-epg-decrypt (handle ctl)
827   (catch 'error
828     (let ((inhibit-redisplay t)
829           context plain child handles result decrypt-status)
830       (unless (setq child (mm-find-part-by-type
831                            (cdr handle)
832                            "application/octet-stream" nil t))
833         (mm-set-handle-multipart-parameter
834          mm-security-handle 'gnus-info "Corrupted")
835         (throw 'error handle))
836       (setq context (epg-make-context))
837       (if (or mml2015-cache-passphrase mml-secure-cache-passphrase)
838           (epg-context-set-passphrase-callback
839            context
840            (cons 'mml-secure-passphrase-callback 'OpenPGP)))
841       (condition-case error
842           (setq plain (epg-decrypt-string context (mm-get-part child))
843                 mml-secure-secret-key-id-list nil)
844         (error
845          (mml-secure-clear-secret-key-id-list)
846          (mm-set-handle-multipart-parameter
847           mm-security-handle 'gnus-info "Failed")
848          (if (eq (car error) 'quit)
849              (mm-set-handle-multipart-parameter
850               mm-security-handle 'gnus-details "Quit.")
851            (mm-set-handle-multipart-parameter
852             mm-security-handle 'gnus-details (mml2015-format-error error)))
853          (throw 'error handle)))
854       (with-temp-buffer
855         (insert plain)
856         (goto-char (point-min))
857         (while (search-forward "\r\n" nil t)
858           (replace-match "\n" t t))
859         (setq handles (mm-dissect-buffer t))
860         (mm-destroy-parts handle)
861         (if (epg-context-result-for context 'verify)
862             (mm-set-handle-multipart-parameter
863              mm-security-handle 'gnus-info
864              (concat "OK\n"
865                      (mml2015-epg-verify-result-to-string
866                       (epg-context-result-for context 'verify))))
867           (mm-set-handle-multipart-parameter
868            mm-security-handle 'gnus-info "OK"))
869         (if (stringp (car handles))
870             (mm-set-handle-multipart-parameter
871              mm-security-handle 'gnus-details
872              (mm-handle-multipart-ctl-parameter handles 'gnus-details))))
873         (if (listp (car handles))
874             handles
875           (list handles)))))
876
877 (defun mml2015-epg-clear-decrypt ()
878   (let ((inhibit-redisplay t)
879         (context (epg-make-context))
880         plain)
881     (if (or mml2015-cache-passphrase mml-secure-cache-passphrase)
882         (epg-context-set-passphrase-callback
883          context
884          (cons 'mml-secure-passphrase-callback 'OpenPGP)))
885     (condition-case error
886         (setq plain (epg-decrypt-string context (buffer-string))
887               mml-secure-secret-key-id-list nil)
888       (error
889        (mml-secure-clear-secret-key-id-list)
890        (mm-set-handle-multipart-parameter
891         mm-security-handle 'gnus-info "Failed")
892        (if (eq (car error) 'quit)
893            (mm-set-handle-multipart-parameter
894             mm-security-handle 'gnus-details "Quit.")
895          (mm-set-handle-multipart-parameter
896           mm-security-handle 'gnus-details (mml2015-format-error error)))))
897     (when plain
898       (erase-buffer)
899       ;; Treat data which epg returns as a unibyte string.
900       (mm-disable-multibyte)
901       (insert plain)
902       (goto-char (point-min))
903       (while (search-forward "\r\n" nil t)
904         (replace-match "\n" t t))
905       (mm-set-handle-multipart-parameter
906        mm-security-handle 'gnus-info "OK")
907       (if (epg-context-result-for context 'verify)
908           (mm-set-handle-multipart-parameter
909            mm-security-handle 'gnus-details
910            (mml2015-epg-verify-result-to-string
911             (epg-context-result-for context 'verify)))))))
912
913 (defun mml2015-epg-verify (handle ctl)
914   (catch 'error
915     (let ((inhibit-redisplay t)
916           context plain signature-file part signature)
917       (when (or (null (setq part (mm-find-raw-part-by-type
918                                   ctl (or (mm-handle-multipart-ctl-parameter
919                                            ctl 'protocol)
920                                           "application/pgp-signature")
921                                   t)))
922                 (null (setq signature (mm-find-part-by-type
923                                        (cdr handle) "application/pgp-signature"
924                                        nil t))))
925         (mm-set-handle-multipart-parameter
926          mm-security-handle 'gnus-info "Corrupted")
927         (throw 'error handle))
928       (setq part (mm-replace-in-string part "\n" "\r\n")
929             signature (mm-get-part signature)
930             context (epg-make-context))
931       (condition-case error
932           (setq plain (epg-verify-string context signature part))
933         (error
934          (mm-set-handle-multipart-parameter
935           mm-security-handle 'gnus-info "Failed")
936          (if (eq (car error) 'quit)
937              (mm-set-handle-multipart-parameter
938               mm-security-handle 'gnus-details "Quit.")
939            (mm-set-handle-multipart-parameter
940             mm-security-handle 'gnus-details (mml2015-format-error error)))
941          (throw 'error handle)))
942       (mm-set-handle-multipart-parameter
943        mm-security-handle 'gnus-info
944        (mml2015-epg-verify-result-to-string
945         (epg-context-result-for context 'verify)))
946       handle)))
947
948 (defun mml2015-epg-clear-verify ()
949   (let ((inhibit-redisplay t)
950         (context (epg-make-context))
951         (signature (mm-encode-coding-string (buffer-string)
952                                             coding-system-for-write))
953         plain)
954     (condition-case error
955         (setq plain (epg-verify-string context signature))
956       (error
957        (mm-set-handle-multipart-parameter
958         mm-security-handle 'gnus-info "Failed")
959        (if (eq (car error) 'quit)
960            (mm-set-handle-multipart-parameter
961             mm-security-handle 'gnus-details "Quit.")
962          (mm-set-handle-multipart-parameter
963           mm-security-handle 'gnus-details (mml2015-format-error error)))))
964     (if plain
965         (progn
966           (mm-set-handle-multipart-parameter
967            mm-security-handle 'gnus-info
968            (mml2015-epg-verify-result-to-string
969             (epg-context-result-for context 'verify)))
970           (delete-region (point-min) (point-max))
971           (insert (mm-decode-coding-string plain coding-system-for-read)))
972       (mml2015-extract-cleartext-signature))))
973
974 (defun mml2015-epg-sign (cont)
975   (let ((inhibit-redisplay t)
976         (boundary (mml-compute-boundary cont)))
977     ;; Signed data must end with a newline (RFC 3156, 5).
978     (goto-char (point-max))
979     (unless (bolp)
980       (insert "\n"))
981     (let* ((pair (mml-secure-epg-sign 'OpenPGP t))
982            (signature (car pair))
983            (micalg (cdr pair)))
984       (goto-char (point-min))
985       (insert (format "Content-Type: multipart/signed; boundary=\"%s\";\n"
986                       boundary))
987       (if micalg
988           (insert (format "\tmicalg=pgp-%s; "
989                           (downcase
990                            (cdr (assq micalg
991                                       epg-digest-algorithm-alist))))))
992       (insert "protocol=\"application/pgp-signature\"\n")
993       (insert (format "\n--%s\n" boundary))
994       (goto-char (point-max))
995       (insert (format "\n--%s\n" boundary))
996       (insert "Content-Type: application/pgp-signature; name=\"signature.asc\"\n\n")
997       (insert signature)
998       (goto-char (point-max))
999       (insert (format "--%s--\n" boundary))
1000       (goto-char (point-max)))))
1001
1002 (defun mml2015-epg-encrypt (cont &optional sign)
1003   (let* ((inhibit-redisplay t)
1004          (boundary (mml-compute-boundary cont))
1005          (cipher (mml-secure-epg-encrypt 'OpenPGP cont sign)))
1006     (delete-region (point-min) (point-max))
1007     (goto-char (point-min))
1008     (insert (format "Content-Type: multipart/encrypted; boundary=\"%s\";\n"
1009                     boundary))
1010     (insert "\tprotocol=\"application/pgp-encrypted\"\n\n")
1011     (insert (format "--%s\n" boundary))
1012     (insert "Content-Type: application/pgp-encrypted\n\n")
1013     (insert "Version: 1\n\n")
1014     (insert (format "--%s\n" boundary))
1015     (insert "Content-Type: application/octet-stream\n\n")
1016     (insert cipher)
1017     (goto-char (point-max))
1018     (insert (format "--%s--\n" boundary))
1019     (goto-char (point-max))))
1020
1021 ;;; General wrapper
1022
1023 (autoload 'gnus-buffer-live-p "gnus-util")
1024 (autoload 'gnus-get-buffer-create "gnus")
1025
1026 (defun mml2015-clean-buffer ()
1027   (if (gnus-buffer-live-p mml2015-result-buffer)
1028       (with-current-buffer mml2015-result-buffer
1029         (erase-buffer)
1030         t)
1031     (setq mml2015-result-buffer
1032           (gnus-get-buffer-create " *MML2015 Result*"))
1033     nil))
1034
1035 (defsubst mml2015-clear-decrypt-function ()
1036   (nth 6 (assq mml2015-use mml2015-function-alist)))
1037
1038 (defsubst mml2015-clear-verify-function ()
1039   (nth 5 (assq mml2015-use mml2015-function-alist)))
1040
1041 ;;;###autoload
1042 (defun mml2015-decrypt (handle ctl)
1043   (mml2015-clean-buffer)
1044   (let ((func (nth 4 (assq mml2015-use mml2015-function-alist))))
1045     (if func
1046         (funcall func handle ctl)
1047       handle)))
1048
1049 ;;;###autoload
1050 (defun mml2015-decrypt-test (handle ctl)
1051   mml2015-use)
1052
1053 ;;;###autoload
1054 (defun mml2015-verify (handle ctl)
1055   (mml2015-clean-buffer)
1056   (let ((func (nth 3 (assq mml2015-use mml2015-function-alist))))
1057     (if func
1058         (funcall func handle ctl)
1059       handle)))
1060
1061 ;;;###autoload
1062 (defun mml2015-verify-test (handle ctl)
1063   mml2015-use)
1064
1065 ;;;###autoload
1066 (defun mml2015-encrypt (cont &optional sign)
1067   (mml2015-clean-buffer)
1068   (let ((func (nth 2 (assq mml2015-use mml2015-function-alist))))
1069     (if func
1070         (funcall func cont sign)
1071       (error "Cannot find encrypt function"))))
1072
1073 ;;;###autoload
1074 (defun mml2015-sign (cont)
1075   (mml2015-clean-buffer)
1076   (let ((func (nth 1 (assq mml2015-use mml2015-function-alist))))
1077     (if func
1078         (funcall func cont)
1079       (error "Cannot find sign function"))))
1080
1081 ;;;###autoload
1082 (defun mml2015-self-encrypt ()
1083   (mml2015-encrypt nil))
1084
1085 (provide 'mml2015)
1086
1087 ;;; mml2015.el ends here