cgit.sxemacs.org Git - gnus/blob - lisp/mml2015.el

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