1;;; mml2015.el --- MIME Security with Pretty Good Privacy (PGP) 2 3;; Copyright (C) 2000, 2001, 2002, 2003, 2004, 4;; 2005, 2006, 2007 Free Software Foundation, Inc. 5 6;; Author: Shenghuo Zhu <zsh@cs.rochester.edu> 7;; Keywords: PGP 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;; RFC 2015 is updated by RFC 3156, this file should be compatible 29;; with both. 30 31;;; Code: 32 33(eval-when-compile (require 'cl)) 34(require 'mm-decode) 35(require 'mm-util) 36(require 'mml) 37 38(defvar mc-pgp-always-sign) 39 40(defvar mml2015-use (or 41 (progn 42 (ignore-errors 43 (require 'pgg)) 44 (and (fboundp 'pgg-sign-region) 45 'pgg)) 46 (progn 47 (ignore-errors 48 (require 'gpg)) 49 (and (fboundp 'gpg-sign-detached) 50 'gpg)) 51 (progn (ignore-errors 52 (load "mc-toplev")) 53 (and (fboundp 'mc-encrypt-generic) 54 (fboundp 'mc-sign-generic) 55 (fboundp 'mc-cleanup-recipient-headers) 56 'mailcrypt))) 57 "The package used for PGP/MIME.") 58 59;; Something is not RFC2015. 60(defvar mml2015-function-alist 61 '((mailcrypt mml2015-mailcrypt-sign 62 mml2015-mailcrypt-encrypt 63 mml2015-mailcrypt-verify 64 mml2015-mailcrypt-decrypt 65 mml2015-mailcrypt-clear-verify 66 mml2015-mailcrypt-clear-decrypt) 67 (gpg mml2015-gpg-sign 68 mml2015-gpg-encrypt 69 mml2015-gpg-verify 70 mml2015-gpg-decrypt 71 mml2015-gpg-clear-verify 72 mml2015-gpg-clear-decrypt) 73 (pgg mml2015-pgg-sign 74 mml2015-pgg-encrypt 75 mml2015-pgg-verify 76 mml2015-pgg-decrypt 77 mml2015-pgg-clear-verify 78 mml2015-pgg-clear-decrypt)) 79 "Alist of PGP/MIME functions.") 80 81(defvar mml2015-result-buffer nil) 82 83(defcustom mml2015-unabbrev-trust-alist 84 '(("TRUST_UNDEFINED" . nil) 85 ("TRUST_NEVER" . nil) 86 ("TRUST_MARGINAL" . t) 87 ("TRUST_FULLY" . t) 88 ("TRUST_ULTIMATE" . t)) 89 "Map GnuPG trust output values to a boolean saying if you trust the key." 90 :version "22.1" 91 :group 'mime-security 92 :type '(repeat (cons (regexp :tag "GnuPG output regexp") 93 (boolean :tag "Trust key")))) 94 95;;; mailcrypt wrapper 96 97(eval-and-compile 98 (autoload 'mailcrypt-decrypt "mailcrypt") 99 (autoload 'mailcrypt-verify "mailcrypt") 100 (autoload 'mc-pgp-always-sign "mailcrypt") 101 (autoload 'mc-encrypt-generic "mc-toplev") 102 (autoload 'mc-cleanup-recipient-headers "mc-toplev") 103 (autoload 'mc-sign-generic "mc-toplev")) 104 105(eval-when-compile 106 (defvar mc-default-scheme) 107 (defvar mc-schemes)) 108 109(defvar mml2015-decrypt-function 'mailcrypt-decrypt) 110(defvar mml2015-verify-function 'mailcrypt-verify) 111 112(defun mml2015-format-error (err) 113 (if (stringp (cadr err)) 114 (cadr err) 115 (format "%S" (cdr err)))) 116 117(defun mml2015-mailcrypt-decrypt (handle ctl) 118 (catch 'error 119 (let (child handles result) 120 (unless (setq child (mm-find-part-by-type 121 (cdr handle) 122 "application/octet-stream" nil t)) 123 (mm-set-handle-multipart-parameter 124 mm-security-handle 'gnus-info "Corrupted") 125 (throw 'error handle)) 126 (with-temp-buffer 127 (mm-insert-part child) 128 (setq result 129 (condition-case err 130 (funcall mml2015-decrypt-function) 131 (error 132 (mm-set-handle-multipart-parameter 133 mm-security-handle 'gnus-details (mml2015-format-error err)) 134 nil) 135 (quit 136 (mm-set-handle-multipart-parameter 137 mm-security-handle 'gnus-details "Quit.") 138 nil))) 139 (unless (car result) 140 (mm-set-handle-multipart-parameter 141 mm-security-handle 'gnus-info "Failed") 142 (throw 'error handle)) 143 (setq handles (mm-dissect-buffer t))) 144 (mm-destroy-parts handle) 145 (mm-set-handle-multipart-parameter 146 mm-security-handle 'gnus-info 147 (concat "OK" 148 (let ((sig (with-current-buffer mml2015-result-buffer 149 (mml2015-gpg-extract-signature-details)))) 150 (concat ", Signer: " sig)))) 151 (if (listp (car handles)) 152 handles 153 (list handles))))) 154 155(defun mml2015-mailcrypt-clear-decrypt () 156 (let (result) 157 (setq result 158 (condition-case err 159 (funcall mml2015-decrypt-function) 160 (error 161 (mm-set-handle-multipart-parameter 162 mm-security-handle 'gnus-details (mml2015-format-error err)) 163 nil) 164 (quit 165 (mm-set-handle-multipart-parameter 166 mm-security-handle 'gnus-details "Quit.") 167 nil))) 168 (if (car result) 169 (mm-set-handle-multipart-parameter 170 mm-security-handle 'gnus-info "OK") 171 (mm-set-handle-multipart-parameter 172 mm-security-handle 'gnus-info "Failed")))) 173 174(defun mml2015-fix-micalg (alg) 175 (and alg 176 ;; Mutt/1.2.5i has seen sending micalg=php-sha1 177 (upcase (if (string-match "^p[gh]p-" alg) 178 (substring alg (match-end 0)) 179 alg)))) 180 181(defun mml2015-mailcrypt-verify (handle ctl) 182 (catch 'error 183 (let (part) 184 (unless (setq part (mm-find-raw-part-by-type 185 ctl (or (mm-handle-multipart-ctl-parameter 186 ctl 'protocol) 187 "application/pgp-signature") 188 t)) 189 (mm-set-handle-multipart-parameter 190 mm-security-handle 'gnus-info "Corrupted") 191 (throw 'error handle)) 192 (with-temp-buffer 193 (insert "-----BEGIN PGP SIGNED MESSAGE-----\n") 194 (insert (format "Hash: %s\n\n" 195 (or (mml2015-fix-micalg 196 (mm-handle-multipart-ctl-parameter 197 ctl 'micalg)) 198 "SHA1"))) 199 (save-restriction 200 (narrow-to-region (point) (point)) 201 (insert part "\n") 202 (goto-char (point-min)) 203 (while (not (eobp)) 204 (if (looking-at "^-") 205 (insert "- ")) 206 (forward-line))) 207 (unless (setq part (mm-find-part-by-type 208 (cdr handle) "application/pgp-signature" nil t)) 209 (mm-set-handle-multipart-parameter 210 mm-security-handle 'gnus-info "Corrupted") 211 (throw 'error handle)) 212 (save-restriction 213 (narrow-to-region (point) (point)) 214 (mm-insert-part part) 215 (goto-char (point-min)) 216 (if (re-search-forward "^-----BEGIN PGP [^-]+-----\r?$" nil t) 217 (replace-match "-----BEGIN PGP SIGNATURE-----" t t)) 218 (if (re-search-forward "^-----END PGP [^-]+-----\r?$" nil t) 219 (replace-match "-----END PGP SIGNATURE-----" t t))) 220 (let ((mc-gpg-debug-buffer (get-buffer-create " *gnus gpg debug*"))) 221 (unless (condition-case err 222 (prog1 223 (funcall mml2015-verify-function) 224 (if (get-buffer " *mailcrypt stderr temp") 225 (mm-set-handle-multipart-parameter 226 mm-security-handle 'gnus-details 227 (with-current-buffer " *mailcrypt stderr temp" 228 (buffer-string)))) 229 (if (get-buffer " *mailcrypt stdout temp") 230 (kill-buffer " *mailcrypt stdout temp")) 231 (if (get-buffer " *mailcrypt stderr temp") 232 (kill-buffer " *mailcrypt stderr temp")) 233 (if (get-buffer " *mailcrypt status temp") 234 (kill-buffer " *mailcrypt status temp")) 235 (if (get-buffer mc-gpg-debug-buffer) 236 (kill-buffer mc-gpg-debug-buffer))) 237 (error 238 (mm-set-handle-multipart-parameter 239 mm-security-handle 'gnus-details (mml2015-format-error err)) 240 nil) 241 (quit 242 (mm-set-handle-multipart-parameter 243 mm-security-handle 'gnus-details "Quit.") 244 nil)) 245 (mm-set-handle-multipart-parameter 246 mm-security-handle 'gnus-info "Failed") 247 (throw 'error handle)))) 248 (mm-set-handle-multipart-parameter 249 mm-security-handle 'gnus-info "OK") 250 handle))) 251 252(defun mml2015-mailcrypt-clear-verify () 253 (let ((mc-gpg-debug-buffer (get-buffer-create " *gnus gpg debug*"))) 254 (if (condition-case err 255 (prog1 256 (funcall mml2015-verify-function) 257 (if (get-buffer " *mailcrypt stderr temp") 258 (mm-set-handle-multipart-parameter 259 mm-security-handle 'gnus-details 260 (with-current-buffer " *mailcrypt stderr temp" 261 (buffer-string)))) 262 (if (get-buffer " *mailcrypt stdout temp") 263 (kill-buffer " *mailcrypt stdout temp")) 264 (if (get-buffer " *mailcrypt stderr temp") 265 (kill-buffer " *mailcrypt stderr temp")) 266 (if (get-buffer " *mailcrypt status temp") 267 (kill-buffer " *mailcrypt status temp")) 268 (if (get-buffer mc-gpg-debug-buffer) 269 (kill-buffer mc-gpg-debug-buffer))) 270 (error 271 (mm-set-handle-multipart-parameter 272 mm-security-handle 'gnus-details (mml2015-format-error err)) 273 nil) 274 (quit 275 (mm-set-handle-multipart-parameter 276 mm-security-handle 'gnus-details "Quit.") 277 nil)) 278 (mm-set-handle-multipart-parameter 279 mm-security-handle 'gnus-info "OK") 280 (mm-set-handle-multipart-parameter 281 mm-security-handle 'gnus-info "Failed")))) 282 283(defun mml2015-mailcrypt-sign (cont) 284 (mc-sign-generic (message-options-get 'message-sender) 285 nil nil nil nil) 286 (let ((boundary (mml-compute-boundary cont)) 287 hash point) 288 (goto-char (point-min)) 289 (unless (re-search-forward "^-----BEGIN PGP SIGNED MESSAGE-----\r?$" nil t) 290 (error "Cannot find signed begin line")) 291 (goto-char (match-beginning 0)) 292 (forward-line 1) 293 (unless (looking-at "Hash:[ \t]*\\([a-zA-Z0-9]+\\)") 294 (error "Cannot not find PGP hash")) 295 (setq hash (match-string 1)) 296 (unless (re-search-forward "^$" nil t) 297 (error "Cannot not find PGP message")) 298 (forward-line 1) 299 (delete-region (point-min) (point)) 300 (insert (format "Content-Type: multipart/signed; boundary=\"%s\";\n" 301 boundary)) 302 (insert (format "\tmicalg=pgp-%s; protocol=\"application/pgp-signature\"\n" 303 (downcase hash))) 304 (insert (format "\n--%s\n" boundary)) 305 (setq point (point)) 306 (goto-char (point-max)) 307 (unless (re-search-backward "^-----END PGP SIGNATURE-----\r?$" nil t) 308 (error "Cannot find signature part")) 309 (replace-match "-----END PGP MESSAGE-----" t t) 310 (goto-char (match-beginning 0)) 311 (unless (re-search-backward "^-----BEGIN PGP SIGNATURE-----\r?$" 312 nil t) 313 (error "Cannot find signature part")) 314 (replace-match "-----BEGIN PGP MESSAGE-----" t t) 315 (goto-char (match-beginning 0)) 316 (save-restriction 317 (narrow-to-region point (point)) 318 (goto-char point) 319 (while (re-search-forward "^- -" nil t) 320 (replace-match "-" t t)) 321 (goto-char (point-max))) 322 (insert (format "--%s\n" boundary)) 323 (insert "Content-Type: application/pgp-signature\n\n") 324 (goto-char (point-max)) 325 (insert (format "--%s--\n" boundary)) 326 (goto-char (point-max)))) 327 328(defun mml2015-mailcrypt-encrypt (cont &optional sign) 329 (let ((mc-pgp-always-sign 330 (or mc-pgp-always-sign 331 sign 332 (eq t (or (message-options-get 'message-sign-encrypt) 333 (message-options-set 334 'message-sign-encrypt 335 (or (y-or-n-p "Sign the message? ") 336 'not)))) 337 'never))) 338 (mm-with-unibyte-current-buffer 339 (mc-encrypt-generic 340 (or (message-options-get 'message-recipients) 341 (message-options-set 'message-recipients 342 (mc-cleanup-recipient-headers 343 (read-string "Recipients: ")))) 344 nil nil nil 345 (message-options-get 'message-sender)))) 346 (goto-char (point-min)) 347 (unless (looking-at "-----BEGIN PGP MESSAGE-----") 348 (error "Fail to encrypt the message")) 349 (let ((boundary (mml-compute-boundary cont))) 350 (insert (format "Content-Type: multipart/encrypted; boundary=\"%s\";\n" 351 boundary)) 352 (insert "\tprotocol=\"application/pgp-encrypted\"\n\n") 353 (insert (format "--%s\n" boundary)) 354 (insert "Content-Type: application/pgp-encrypted\n\n") 355 (insert "Version: 1\n\n") 356 (insert (format "--%s\n" boundary)) 357 (insert "Content-Type: application/octet-stream\n\n") 358 (goto-char (point-max)) 359 (insert (format "--%s--\n" boundary)) 360 (goto-char (point-max)))) 361 362;;; gpg wrapper 363 364(eval-and-compile 365 (autoload 'gpg-decrypt "gpg") 366 (autoload 'gpg-verify "gpg") 367 (autoload 'gpg-verify-cleartext "gpg") 368 (autoload 'gpg-sign-detached "gpg") 369 (autoload 'gpg-sign-encrypt "gpg") 370 (autoload 'gpg-encrypt "gpg") 371 (autoload 'gpg-passphrase-read "gpg")) 372 373(defun mml2015-gpg-passphrase () 374 (or (message-options-get 'gpg-passphrase) 375 (message-options-set 'gpg-passphrase (gpg-passphrase-read)))) 376 377(defun mml2015-gpg-decrypt-1 () 378 (let ((cipher (current-buffer)) plain result) 379 (if (with-temp-buffer 380 (prog1 381 (gpg-decrypt cipher (setq plain (current-buffer)) 382 mml2015-result-buffer nil) 383 (mm-set-handle-multipart-parameter 384 mm-security-handle 'gnus-details 385 (with-current-buffer mml2015-result-buffer 386 (buffer-string))) 387 (set-buffer cipher) 388 (erase-buffer) 389 (insert-buffer-substring plain) 390 (goto-char (point-min)) 391 (while (search-forward "\r\n" nil t) 392 (replace-match "\n" t t)))) 393 '(t) 394 ;; Some wrong with the return value, check plain text buffer. 395 (if (> (point-max) (point-min)) 396 '(t) 397 nil)))) 398 399(defun mml2015-gpg-decrypt (handle ctl) 400 (let ((mml2015-decrypt-function 'mml2015-gpg-decrypt-1)) 401 (mml2015-mailcrypt-decrypt handle ctl))) 402 403(defun mml2015-gpg-clear-decrypt () 404 (let (result) 405 (setq result (mml2015-gpg-decrypt-1)) 406 (if (car result) 407 (mm-set-handle-multipart-parameter 408 mm-security-handle 'gnus-info "OK") 409 (mm-set-handle-multipart-parameter 410 mm-security-handle 'gnus-info "Failed")))) 411 412(defun mml2015-gpg-pretty-print-fpr (fingerprint) 413 (let* ((result "") 414 (fpr-length (string-width fingerprint)) 415 (n-slice 0) 416 slice) 417 (setq fingerprint (string-to-list fingerprint)) 418 (while fingerprint 419 (setq fpr-length (- fpr-length 4)) 420 (setq slice (butlast fingerprint fpr-length)) 421 (setq fingerprint (nthcdr 4 fingerprint)) 422 (setq n-slice (1+ n-slice)) 423 (setq result 424 (concat 425 result 426 (case n-slice 427 (1 slice) 428 (otherwise (concat " " slice)))))) 429 result)) 430 431(defun mml2015-gpg-extract-signature-details () 432 (goto-char (point-min)) 433 (let* ((expired (re-search-forward 434 "^\\[GNUPG:\\] SIGEXPIRED$" 435 nil t)) 436 (signer (and (re-search-forward 437 "^\\[GNUPG:\\] GOODSIG \\([0-9A-Za-z]*\\) \\(.*\\)$" 438 nil t) 439 (cons (match-string 1) (match-string 2)))) 440 (fprint (and (re-search-forward 441 "^\\[GNUPG:\\] VALIDSIG \\([0-9a-zA-Z]*\\) " 442 nil t) 443 (match-string 1))) 444 (trust (and (re-search-forward 445 "^\\[GNUPG:\\] \\(TRUST_.*\\)$" 446 nil t) 447 (match-string 1))) 448 (trust-good-enough-p 449 (cdr (assoc trust mml2015-unabbrev-trust-alist)))) 450 (cond ((and signer fprint) 451 (concat (cdr signer) 452 (unless trust-good-enough-p 453 (concat "\nUntrusted, Fingerprint: " 454 (mml2015-gpg-pretty-print-fpr fprint))) 455 (when expired 456 (format "\nWARNING: Signature from expired key (%s)" 457 (car signer))))) 458 ((re-search-forward 459 "^\\(gpg: \\)?Good signature from \"\\(.*\\)\"$" nil t) 460 (match-string 2)) 461 (t 462 "From unknown user")))) 463 464(defun mml2015-gpg-verify (handle ctl) 465 (catch 'error 466 (let (part message signature info-is-set-p) 467 (unless (setq part (mm-find-raw-part-by-type 468 ctl (or (mm-handle-multipart-ctl-parameter 469 ctl 'protocol) 470 "application/pgp-signature") 471 t)) 472 (mm-set-handle-multipart-parameter 473 mm-security-handle 'gnus-info "Corrupted") 474 (throw 'error handle)) 475 (with-temp-buffer 476 (setq message (current-buffer)) 477 (insert part) 478 ;; Convert <LF> to <CR><LF> in verify mode. Sign and 479 ;; clearsign use --textmode. The conversion is not necessary. 480 ;; In clearverify, the conversion is not necessary either. 481 (goto-char (point-min)) 482 (end-of-line) 483 (while (not (eobp)) 484 (unless (eq (char-before) ?\r) 485 (insert "\r")) 486 (forward-line) 487 (end-of-line)) 488 (with-temp-buffer 489 (setq signature (current-buffer)) 490 (unless (setq part (mm-find-part-by-type 491 (cdr handle) "application/pgp-signature" nil t)) 492 (mm-set-handle-multipart-parameter 493 mm-security-handle 'gnus-info "Corrupted") 494 (throw 'error handle)) 495 (mm-insert-part part) 496 (unless (condition-case err 497 (prog1 498 (gpg-verify message signature mml2015-result-buffer) 499 (mm-set-handle-multipart-parameter 500 mm-security-handle 'gnus-details 501 (with-current-buffer mml2015-result-buffer 502 (buffer-string)))) 503 (error 504 (mm-set-handle-multipart-parameter 505 mm-security-handle 'gnus-details (mml2015-format-error err)) 506 (mm-set-handle-multipart-parameter 507 mm-security-handle 'gnus-info "Error.") 508 (setq info-is-set-p t) 509 nil) 510 (quit 511 (mm-set-handle-multipart-parameter 512 mm-security-handle 'gnus-details "Quit.") 513 (mm-set-handle-multipart-parameter 514 mm-security-handle 'gnus-info "Quit.") 515 (setq info-is-set-p t) 516 nil)) 517 (unless info-is-set-p 518 (mm-set-handle-multipart-parameter 519 mm-security-handle 'gnus-info "Failed")) 520 (throw 'error handle))) 521 (mm-set-handle-multipart-parameter 522 mm-security-handle 'gnus-info 523 (with-current-buffer mml2015-result-buffer 524 (mml2015-gpg-extract-signature-details)))) 525 handle))) 526 527(defun mml2015-gpg-clear-verify () 528 (if (condition-case err 529 (prog1 530 (gpg-verify-cleartext (current-buffer) mml2015-result-buffer) 531 (mm-set-handle-multipart-parameter 532 mm-security-handle 'gnus-details 533 (with-current-buffer mml2015-result-buffer 534 (buffer-string)))) 535 (error 536 (mm-set-handle-multipart-parameter 537 mm-security-handle 'gnus-details (mml2015-format-error err)) 538 nil) 539 (quit 540 (mm-set-handle-multipart-parameter 541 mm-security-handle 'gnus-details "Quit.") 542 nil)) 543 (mm-set-handle-multipart-parameter 544 mm-security-handle 'gnus-info 545 (with-current-buffer mml2015-result-buffer 546 (mml2015-gpg-extract-signature-details))) 547 (mm-set-handle-multipart-parameter 548 mm-security-handle 'gnus-info "Failed"))) 549 550(defun mml2015-gpg-sign (cont) 551 (let ((boundary (mml-compute-boundary cont)) 552 (text (current-buffer)) signature) 553 (goto-char (point-max)) 554 (unless (bolp) 555 (insert "\n")) 556 (with-temp-buffer 557 (unless (gpg-sign-detached text (setq signature (current-buffer)) 558 mml2015-result-buffer 559 nil 560 (message-options-get 'message-sender) 561 t t) ; armor & textmode 562 (unless (> (point-max) (point-min)) 563 (pop-to-buffer mml2015-result-buffer) 564 (error "Sign error"))) 565 (goto-char (point-min)) 566 (while (re-search-forward "\r+$" nil t) 567 (replace-match "" t t)) 568 (set-buffer text) 569 (goto-char (point-min)) 570 (insert (format "Content-Type: multipart/signed; boundary=\"%s\";\n" 571 boundary)) 572 ;;; FIXME: what is the micalg? 573 (insert "\tmicalg=pgp-sha1; protocol=\"application/pgp-signature\"\n") 574 (insert (format "\n--%s\n" boundary)) 575 (goto-char (point-max)) 576 (insert (format "\n--%s\n" boundary)) 577 (insert "Content-Type: application/pgp-signature\n\n") 578 (insert-buffer-substring signature) 579 (goto-char (point-max)) 580 (insert (format "--%s--\n" boundary)) 581 (goto-char (point-max))))) 582 583(defun mml2015-gpg-encrypt (cont &optional sign) 584 (let ((boundary (mml-compute-boundary cont)) 585 (text (current-buffer)) 586 cipher) 587 (mm-with-unibyte-current-buffer 588 (with-temp-buffer 589 ;; set up a function to call the correct gpg encrypt routine 590 ;; with the right arguments. (FIXME: this should be done 591 ;; differently.) 592 (flet ((gpg-encrypt-func 593 (sign plaintext ciphertext result recipients &optional 594 passphrase sign-with-key armor textmode) 595 (if sign 596 (gpg-sign-encrypt 597 plaintext ciphertext result recipients passphrase 598 sign-with-key armor textmode) 599 (gpg-encrypt 600 plaintext ciphertext result recipients passphrase 601 armor textmode)))) 602 (unless (gpg-encrypt-func 603 sign ; passed in when using signencrypt 604 text (setq cipher (current-buffer)) 605 mml2015-result-buffer 606 (split-string 607 (or 608 (message-options-get 'message-recipients) 609 (message-options-set 'message-recipients 610 (read-string "Recipients: "))) 611 "[ \f\t\n\r\v,]+") 612 nil 613 (message-options-get 'message-sender) 614 t t) ; armor & textmode 615 (unless (> (point-max) (point-min)) 616 (pop-to-buffer mml2015-result-buffer) 617 (error "Encrypt error")))) 618 (goto-char (point-min)) 619 (while (re-search-forward "\r+$" nil t) 620 (replace-match "" t t)) 621 (set-buffer text) 622 (delete-region (point-min) (point-max)) 623 (insert (format "Content-Type: multipart/encrypted; boundary=\"%s\";\n" 624 boundary)) 625 (insert "\tprotocol=\"application/pgp-encrypted\"\n\n") 626 (insert (format "--%s\n" boundary)) 627 (insert "Content-Type: application/pgp-encrypted\n\n") 628 (insert "Version: 1\n\n") 629 (insert (format "--%s\n" boundary)) 630 (insert "Content-Type: application/octet-stream\n\n") 631 (insert-buffer-substring cipher) 632 (goto-char (point-max)) 633 (insert (format "--%s--\n" boundary)) 634 (goto-char (point-max)))))) 635 636;;; pgg wrapper 637 638(eval-when-compile 639 (defvar pgg-default-user-id) 640 (defvar pgg-errors-buffer) 641 (defvar pgg-output-buffer)) 642 643(eval-and-compile 644 (autoload 'pgg-decrypt-region "pgg") 645 (autoload 'pgg-verify-region "pgg") 646 (autoload 'pgg-sign-region "pgg") 647 (autoload 'pgg-encrypt-region "pgg") 648 (autoload 'pgg-parse-armor "pgg-parse")) 649 650(defun mml2015-pgg-decrypt (handle ctl) 651 (catch 'error 652 (let ((pgg-errors-buffer mml2015-result-buffer) 653 child handles result decrypt-status) 654 (unless (setq child (mm-find-part-by-type 655 (cdr handle) 656 "application/octet-stream" nil t)) 657 (mm-set-handle-multipart-parameter 658 mm-security-handle 'gnus-info "Corrupted") 659 (throw 'error handle)) 660 (with-temp-buffer 661 (mm-insert-part child) 662 (if (condition-case err 663 (prog1 664 (pgg-decrypt-region (point-min) (point-max)) 665 (setq decrypt-status 666 (with-current-buffer mml2015-result-buffer 667 (buffer-string))) 668 (mm-set-handle-multipart-parameter 669 mm-security-handle 'gnus-details 670 decrypt-status)) 671 (error 672 (mm-set-handle-multipart-parameter 673 mm-security-handle 'gnus-details (mml2015-format-error err)) 674 nil) 675 (quit 676 (mm-set-handle-multipart-parameter 677 mm-security-handle 'gnus-details "Quit.") 678 nil)) 679 (with-current-buffer pgg-output-buffer 680 (goto-char (point-min)) 681 (while (search-forward "\r\n" nil t) 682 (replace-match "\n" t t)) 683 (setq handles (mm-dissect-buffer t)) 684 (mm-destroy-parts handle) 685 (mm-set-handle-multipart-parameter 686 mm-security-handle 'gnus-info "OK") 687 (mm-set-handle-multipart-parameter 688 mm-security-handle 'gnus-details 689 (concat decrypt-status 690 (when (stringp (car handles)) 691 "\n" (mm-handle-multipart-ctl-parameter 692 handles 'gnus-details)))) 693 (if (listp (car handles)) 694 handles 695 (list handles))) 696 (mm-set-handle-multipart-parameter 697 mm-security-handle 'gnus-info "Failed") 698 (throw 'error handle)))))) 699 700(defun mml2015-pgg-clear-decrypt () 701 (let ((pgg-errors-buffer mml2015-result-buffer)) 702 (if (prog1 703 (pgg-decrypt-region (point-min) (point-max)) 704 (mm-set-handle-multipart-parameter 705 mm-security-handle 'gnus-details 706 (with-current-buffer mml2015-result-buffer 707 (buffer-string)))) 708 (progn 709 (erase-buffer) 710 ;; Treat data which pgg returns as a unibyte string. 711 (mm-disable-multibyte) 712 (insert-buffer-substring pgg-output-buffer) 713 (goto-char (point-min)) 714 (while (search-forward "\r\n" nil t) 715 (replace-match "\n" t t)) 716 (mm-set-handle-multipart-parameter 717 mm-security-handle 'gnus-info "OK")) 718 (mm-set-handle-multipart-parameter 719 mm-security-handle 'gnus-info "Failed")))) 720 721(defun mml2015-pgg-verify (handle ctl) 722 (let ((pgg-errors-buffer mml2015-result-buffer) 723 signature-file part signature) 724 (if (or (null (setq part (mm-find-raw-part-by-type 725 ctl (or (mm-handle-multipart-ctl-parameter 726 ctl 'protocol) 727 "application/pgp-signature") 728 t))) 729 (null (setq signature (mm-find-part-by-type 730 (cdr handle) "application/pgp-signature" nil t)))) 731 (progn 732 (mm-set-handle-multipart-parameter 733 mm-security-handle 'gnus-info "Corrupted") 734 handle) 735 (with-temp-buffer 736 (insert part) 737 ;; Convert <LF> to <CR><LF> in verify mode. Sign and 738 ;; clearsign use --textmode. The conversion is not necessary. 739 ;; In clearverify, the conversion is not necessary either. 740 (goto-char (point-min)) 741 (end-of-line) 742 (while (not (eobp)) 743 (unless (eq (char-before) ?\r) 744 (insert "\r")) 745 (forward-line) 746 (end-of-line)) 747 (with-temp-file (setq signature-file (mm-make-temp-file "pgg")) 748 (mm-insert-part signature)) 749 (if (condition-case err 750 (prog1 751 (pgg-verify-region (point-min) (point-max) 752 signature-file t) 753 (goto-char (point-min)) 754 (while (search-forward "\r\n" nil t) 755 (replace-match "\n" t t)) 756 (mm-set-handle-multipart-parameter 757 mm-security-handle 'gnus-details 758 (concat (with-current-buffer pgg-output-buffer 759 (buffer-string)) 760 (with-current-buffer pgg-errors-buffer 761 (buffer-string))))) 762 (error 763 (mm-set-handle-multipart-parameter 764 mm-security-handle 'gnus-details (mml2015-format-error err)) 765 nil) 766 (quit 767 (mm-set-handle-multipart-parameter 768 mm-security-handle 'gnus-details "Quit.") 769 nil)) 770 (progn 771 (delete-file signature-file) 772 (mm-set-handle-multipart-parameter 773 mm-security-handle 'gnus-info 774 (with-current-buffer pgg-errors-buffer 775 (mml2015-gpg-extract-signature-details)))) 776 (delete-file signature-file) 777 (mm-set-handle-multipart-parameter 778 mm-security-handle 'gnus-info "Failed"))))) 779 handle) 780 781(defun mml2015-pgg-clear-verify () 782 (let ((pgg-errors-buffer mml2015-result-buffer) 783 (text (buffer-string)) 784 (coding-system buffer-file-coding-system)) 785 (if (condition-case err 786 (prog1 787 (mm-with-unibyte-buffer 788 (insert (mm-encode-coding-string text coding-system)) 789 (pgg-verify-region (point-min) (point-max) nil t)) 790 (goto-char (point-min)) 791 (while (search-forward "\r\n" nil t) 792 (replace-match "\n" t t)) 793 (mm-set-handle-multipart-parameter 794 mm-security-handle 'gnus-details 795 (concat (with-current-buffer pgg-output-buffer 796 (buffer-string)) 797 (with-current-buffer pgg-errors-buffer 798 (buffer-string))))) 799 (error 800 (mm-set-handle-multipart-parameter 801 mm-security-handle 'gnus-details (mml2015-format-error err)) 802 nil) 803 (quit 804 (mm-set-handle-multipart-parameter 805 mm-security-handle 'gnus-details "Quit.") 806 nil)) 807 (mm-set-handle-multipart-parameter 808 mm-security-handle 'gnus-info 809 (with-current-buffer pgg-errors-buffer 810 (mml2015-gpg-extract-signature-details))) 811 (mm-set-handle-multipart-parameter 812 mm-security-handle 'gnus-info "Failed")))) 813 814(defun mml2015-pgg-sign (cont) 815 (let ((pgg-errors-buffer mml2015-result-buffer) 816 (boundary (mml-compute-boundary cont)) 817 (pgg-default-user-id (or (message-options-get 'mml-sender) 818 pgg-default-user-id)) 819 (pgg-text-mode t) 820 entry) 821 (unless (pgg-sign-region (point-min) (point-max)) 822 (pop-to-buffer mml2015-result-buffer) 823 (error "Sign error")) 824 (goto-char (point-min)) 825 (insert (format "Content-Type: multipart/signed; boundary=\"%s\";\n" 826 boundary)) 827 (if (setq entry (assq 2 (pgg-parse-armor 828 (with-current-buffer pgg-output-buffer 829 (buffer-string))))) 830 (setq entry (assq 'hash-algorithm (cdr entry)))) 831 (insert (format "\tmicalg=%s; " 832 (if (cdr entry) 833 (downcase (format "pgp-%s" (cdr entry))) 834 "pgp-sha1"))) 835 (insert "protocol=\"application/pgp-signature\"\n") 836 (insert (format "\n--%s\n" boundary)) 837 (goto-char (point-max)) 838 (insert (format "\n--%s\n" boundary)) 839 (insert "Content-Type: application/pgp-signature\n\n") 840 (insert-buffer-substring pgg-output-buffer) 841 (goto-char (point-max)) 842 (insert (format "--%s--\n" boundary)) 843 (goto-char (point-max)))) 844 845(defun mml2015-pgg-encrypt (cont &optional sign) 846 (let ((pgg-errors-buffer mml2015-result-buffer) 847 (pgg-text-mode t) 848 (boundary (mml-compute-boundary cont))) 849 (unless (pgg-encrypt-region (point-min) (point-max) 850 (split-string 851 (or 852 (message-options-get 'message-recipients) 853 (message-options-set 'message-recipients 854 (read-string "Recipients: "))) 855 "[ \f\t\n\r\v,]+") 856 sign) 857 (pop-to-buffer mml2015-result-buffer) 858 (error "Encrypt error")) 859 (delete-region (point-min) (point-max)) 860 (goto-char (point-min)) 861 (insert (format "Content-Type: multipart/encrypted; boundary=\"%s\";\n" 862 boundary)) 863 (insert "\tprotocol=\"application/pgp-encrypted\"\n\n") 864 (insert (format "--%s\n" boundary)) 865 (insert "Content-Type: application/pgp-encrypted\n\n") 866 (insert "Version: 1\n\n") 867 (insert (format "--%s\n" boundary)) 868 (insert "Content-Type: application/octet-stream\n\n") 869 (insert-buffer-substring pgg-output-buffer) 870 (goto-char (point-max)) 871 (insert (format "--%s--\n" boundary)) 872 (goto-char (point-max)))) 873 874;;; General wrapper 875 876(defun mml2015-clean-buffer () 877 (if (gnus-buffer-live-p mml2015-result-buffer) 878 (with-current-buffer mml2015-result-buffer 879 (erase-buffer) 880 t) 881 (setq mml2015-result-buffer 882 (gnus-get-buffer-create "*MML2015 Result*")) 883 nil)) 884 885(defsubst mml2015-clear-decrypt-function () 886 (nth 6 (assq mml2015-use mml2015-function-alist))) 887 888(defsubst mml2015-clear-verify-function () 889 (nth 5 (assq mml2015-use mml2015-function-alist))) 890 891;;;###autoload 892(defun mml2015-decrypt (handle ctl) 893 (mml2015-clean-buffer) 894 (let ((func (nth 4 (assq mml2015-use mml2015-function-alist)))) 895 (if func 896 (funcall func handle ctl) 897 handle))) 898 899;;;###autoload 900(defun mml2015-decrypt-test (handle ctl) 901 mml2015-use) 902 903;;;###autoload 904(defun mml2015-verify (handle ctl) 905 (mml2015-clean-buffer) 906 (let ((func (nth 3 (assq mml2015-use mml2015-function-alist)))) 907 (if func 908 (funcall func handle ctl) 909 handle))) 910 911;;;###autoload 912(defun mml2015-verify-test (handle ctl) 913 mml2015-use) 914 915;;;###autoload 916(defun mml2015-encrypt (cont &optional sign) 917 (mml2015-clean-buffer) 918 (let ((func (nth 2 (assq mml2015-use mml2015-function-alist)))) 919 (if func 920 (funcall func cont sign) 921 (error "Cannot find encrypt function")))) 922 923;;;###autoload 924(defun mml2015-sign (cont) 925 (mml2015-clean-buffer) 926 (let ((func (nth 1 (assq mml2015-use mml2015-function-alist)))) 927 (if func 928 (funcall func cont) 929 (error "Cannot find sign function")))) 930 931;;;###autoload 932(defun mml2015-self-encrypt () 933 (mml2015-encrypt nil)) 934 935(provide 'mml2015) 936 937;;; arch-tag: b04701d5-0b09-44d8-bed8-de901bf435f2 938;;; mml2015.el ends here 939