code.delx.au - gnu-emacs/blob - lisp/gnus/mml1991.el

   1 ;;; mml1991.el --- Old PGP message format (RFC 1991) support for MML
   2
   3 ;; Copyright (C) 1998-2016 Free Software Foundation, Inc.
   4
   5 ;; Author: Sascha Lüdecke <sascha@meta-x.de>,
   6 ;;      Simon Josefsson <simon@josefsson.org> (Mailcrypt interface, Gnus glue)
   7 ;; Keywords: PGP
   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 by
  13 ;; the Free Software Foundation, either version 3 of the License, or
  14 ;; (at your option) any later version.
  15
  16 ;; GNU Emacs is distributed in the hope that it will be useful,
  17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19 ;; GNU 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.  If not, see <http://www.gnu.org/licenses/>.
  23
  24 ;;; Commentary:
  25
  26 ;;; Code:
  27
  28 (eval-and-compile
  29   (if (locate-library "password-cache")
  30       (require 'password-cache)
  31     (require 'password)))
  32
  33 (eval-when-compile
  34   (require 'cl)
  35   (require 'mm-util))
  36
  37 (require 'mm-encode)
  38 (require 'mml-sec)
  39
  40 (defvar mc-pgp-always-sign)
  41
  42 (autoload 'quoted-printable-decode-region "qp")
  43 (autoload 'quoted-printable-encode-region "qp")
  44
  45 (autoload 'mm-decode-content-transfer-encoding "mm-bodies")
  46 (autoload 'mm-encode-content-transfer-encoding "mm-bodies")
  47 (autoload 'message-options-get "message")
  48 (autoload 'message-options-set "message")
  49
  50 (require 'mml2015)
  51
  52 (defvar mml1991-use mml2015-use
  53   "The package used for PGP.")
  54
  55 (defvar mml1991-function-alist
  56   '((mailcrypt mml1991-mailcrypt-sign
  57                mml1991-mailcrypt-encrypt)
  58     (pgg mml1991-pgg-sign
  59          mml1991-pgg-encrypt)
  60     (epg mml1991-epg-sign
  61          mml1991-epg-encrypt))
  62   "Alist of PGP functions.")
  63
  64 (defvar mml1991-cache-passphrase mml-secure-cache-passphrase
  65   "If t, cache passphrase.")
  66 (make-obsolete-variable 'mml1991-cache-passphrase
  67                         'mml-secure-cache-passphrase
  68                         "25.1")
  69
  70 (defvar mml1991-passphrase-cache-expiry mml-secure-passphrase-cache-expiry
  71   "How many seconds the passphrase is cached.
  72 Whether the passphrase is cached at all is controlled by
  73 `mml1991-cache-passphrase'.")
  74 (make-obsolete-variable 'mml1991-passphrase-cache-expiry
  75                         'mml-secure-passphrase-cache-expiry
  76                         "25.1")
  77
  78 (defvar mml1991-signers nil
  79   "A list of your own key ID which will be used to sign a message.")
  80
  81 (defvar mml1991-encrypt-to-self nil
  82   "If t, add your own key ID to recipient list when encryption.")
  83
  84
  85 ;;; mailcrypt wrapper
  86
  87 (autoload 'mc-sign-generic "mc-toplev")
  88
  89 (defvar mml1991-decrypt-function 'mailcrypt-decrypt)
  90 (defvar mml1991-verify-function 'mailcrypt-verify)
  91
  92 (defun mml1991-mailcrypt-sign (cont)
  93   (let ((text (current-buffer))
  94         headers signature
  95         (result-buffer (get-buffer-create "*GPG Result*")))
  96     ;; Save MIME Content[^ ]+: headers from signing
  97     (goto-char (point-min))
  98     (while (looking-at "^Content[^ ]+:") (forward-line))
  99     (unless (bobp)
 100       (setq headers (buffer-string))
 101       (delete-region (point-min) (point)))
 102     (goto-char (point-max))
 103     (unless (bolp)
 104       (insert "\n"))
 105     (quoted-printable-decode-region (point-min) (point-max))
 106     (with-temp-buffer
 107       (setq signature (current-buffer))
 108       (insert-buffer-substring text)
 109       (unless (mc-sign-generic (message-options-get 'message-sender)
 110                                nil nil nil nil)
 111         (unless (> (point-max) (point-min))
 112           (pop-to-buffer result-buffer)
 113           (error "Sign error")))
 114       (goto-char (point-min))
 115       (while (re-search-forward "\r+$" nil t)
 116         (replace-match "" t t))
 117       (quoted-printable-encode-region (point-min) (point-max))
 118       (set-buffer text)
 119       (delete-region (point-min) (point-max))
 120       (if headers (insert headers))
 121       (insert "\n")
 122       (insert-buffer-substring signature)
 123       (goto-char (point-max)))))
 124
 125 (declare-function mc-encrypt-generic "ext:mc-toplev"
 126                   (&optional recipients scheme start end from sign))
 127
 128 (defun mml1991-mailcrypt-encrypt (cont &optional sign)
 129   (let ((text (current-buffer))
 130         (mc-pgp-always-sign
 131          (or mc-pgp-always-sign
 132              sign
 133              (eq t (or (message-options-get 'message-sign-encrypt)
 134                        (message-options-set
 135                         'message-sign-encrypt
 136                         (or (y-or-n-p "Sign the message? ")
 137                             'not))))
 138              'never))
 139         cipher
 140         (result-buffer (get-buffer-create "*GPG Result*")))
 141     ;; Strip MIME Content[^ ]: headers since it will be ASCII ARMORED
 142     (goto-char (point-min))
 143     (while (looking-at "^Content[^ ]+:") (forward-line))
 144     (unless (bobp)
 145       (delete-region (point-min) (point)))
 146     (with-temp-buffer
 147       (inline (mm-disable-multibyte))
 148       (setq cipher (current-buffer))
 149       (insert-buffer-substring text)
 150       (unless (mc-encrypt-generic
 151                (or
 152                 (message-options-get 'message-recipients)
 153                 (message-options-set 'message-recipients
 154                                      (read-string "Recipients: ")))
 155                nil
 156                (point-min) (point-max)
 157                (message-options-get 'message-sender)
 158                'sign)
 159         (unless (> (point-max) (point-min))
 160           (pop-to-buffer result-buffer)
 161           (error "Encrypt error")))
 162       (goto-char (point-min))
 163       (while (re-search-forward "\r+$" nil t)
 164         (replace-match "" t t))
 165       (set-buffer text)
 166       (delete-region (point-min) (point-max))
 167       ;;(insert "Content-Type: application/pgp-encrypted\n\n")
 168       ;;(insert "Version: 1\n\n")
 169       (insert "\n")
 170       (insert-buffer-substring cipher)
 171       (goto-char (point-max)))))
 172
 173 ;; pgg wrapper
 174
 175 (autoload 'pgg-sign-region "pgg")
 176 (autoload 'pgg-encrypt-region "pgg")
 177
 178 (defvar pgg-default-user-id)
 179 (defvar pgg-errors-buffer)
 180 (defvar pgg-output-buffer)
 181
 182 (defun mml1991-pgg-sign (cont)
 183   (let ((pgg-text-mode t)
 184         (pgg-default-user-id (or (message-options-get 'mml-sender)
 185                                  pgg-default-user-id))
 186         headers cte)
 187     ;; Don't sign headers.
 188     (goto-char (point-min))
 189     (when (re-search-forward "^$" nil t)
 190       (setq headers (buffer-substring (point-min) (point)))
 191       (save-restriction
 192         (narrow-to-region (point-min) (point))
 193         (setq cte (mail-fetch-field "content-transfer-encoding")))
 194       (forward-line 1)
 195       (delete-region (point-min) (point))
 196       (when cte
 197         (setq cte (intern (downcase cte)))
 198         (mm-decode-content-transfer-encoding cte)))
 199     (unless (pgg-sign-region (point-min) (point-max) t)
 200       (pop-to-buffer pgg-errors-buffer)
 201       (error "Encrypt error"))
 202     (delete-region (point-min) (point-max))
 203     (mm-with-unibyte-current-buffer
 204       (insert-buffer-substring pgg-output-buffer)
 205       (goto-char (point-min))
 206       (while (re-search-forward "\r+$" nil t)
 207         (replace-match "" t t))
 208       (when cte
 209         (mm-encode-content-transfer-encoding cte))
 210       (goto-char (point-min))
 211       (when headers
 212         (insert headers))
 213       (insert "\n"))
 214     t))
 215
 216 (defun mml1991-pgg-encrypt (cont &optional sign)
 217   (goto-char (point-min))
 218   (when (re-search-forward "^$" nil t)
 219     (let ((cte (save-restriction
 220                  (narrow-to-region (point-min) (point))
 221                  (mail-fetch-field "content-transfer-encoding"))))
 222       ;; Strip MIME headers since it will be ASCII armored.
 223       (forward-line 1)
 224       (delete-region (point-min) (point))
 225       (when cte
 226         (mm-decode-content-transfer-encoding (intern (downcase cte))))))
 227   (unless (let ((pgg-text-mode t))
 228             (pgg-encrypt-region
 229              (point-min) (point-max)
 230              (split-string
 231               (or
 232                (message-options-get 'message-recipients)
 233                (message-options-set 'message-recipients
 234                                     (read-string "Recipients: ")))
 235               "[ \f\t\n\r\v,]+")
 236              sign))
 237     (pop-to-buffer pgg-errors-buffer)
 238     (error "Encrypt error"))
 239   (delete-region (point-min) (point-max))
 240   (insert "\n")
 241   (insert-buffer-substring pgg-output-buffer)
 242   t)
 243
 244 ;; epg wrapper
 245
 246 (defvar epg-user-id-alist)
 247
 248 (autoload 'epg-make-context "epg")
 249 (autoload 'epg-passphrase-callback-function "epg")
 250 (autoload 'epa-select-keys "epa")
 251 (autoload 'epg-list-keys "epg")
 252 (autoload 'epg-context-set-armor "epg")
 253 (autoload 'epg-context-set-textmode "epg")
 254 (autoload 'epg-context-set-signers "epg")
 255 (autoload 'epg-context-set-passphrase-callback "epg")
 256 (autoload 'epg-key-sub-key-list "epg")
 257 (autoload 'epg-sub-key-capability "epg")
 258 (autoload 'epg-sub-key-validity "epg")
 259 (autoload 'epg-sub-key-fingerprint "epg")
 260 (autoload 'epg-sign-string "epg")
 261 (autoload 'epg-encrypt-string "epg")
 262 (autoload 'epg-configuration "epg-config")
 263 (autoload 'epg-expand-group "epg-config")
 264
 265 (defun mml1991-epg-sign (cont)
 266   (let ((inhibit-redisplay t)
 267         headers cte)
 268     ;; Don't sign headers.
 269     (goto-char (point-min))
 270     (when (re-search-forward "^$" nil t)
 271       (setq headers (buffer-substring (point-min) (point)))
 272       (save-restriction
 273         (narrow-to-region (point-min) (point))
 274         (setq cte (mail-fetch-field "content-transfer-encoding")))
 275       (forward-line 1)
 276       (delete-region (point-min) (point))
 277       (when cte
 278         (setq cte (intern (downcase cte)))
 279         (mm-decode-content-transfer-encoding cte)))
 280     (let* ((pair (mml-secure-epg-sign 'OpenPGP 'clear))
 281            (signature (car pair)))
 282       (delete-region (point-min) (point-max))
 283       (mm-with-unibyte-current-buffer
 284         (insert signature)
 285         (goto-char (point-min))
 286         (while (re-search-forward "\r+$" nil t)
 287           (replace-match "" t t))
 288         (when cte
 289           (mm-encode-content-transfer-encoding cte))
 290         (goto-char (point-min))
 291         (when headers
 292           (insert headers))
 293         (insert "\n"))
 294       t)))
 295
 296 (defun mml1991-epg-encrypt (cont &optional sign)
 297   (goto-char (point-min))
 298   (when (re-search-forward "^$" nil t)
 299     (let ((cte (save-restriction
 300                  (narrow-to-region (point-min) (point))
 301                  (mail-fetch-field "content-transfer-encoding"))))
 302       ;; Strip MIME headers since it will be ASCII armored.
 303       (forward-line 1)
 304       (delete-region (point-min) (point))
 305       (when cte
 306         (mm-decode-content-transfer-encoding (intern (downcase cte))))))
 307   (let ((cipher (mml-secure-epg-encrypt 'OpenPGP cont sign)))
 308     (delete-region (point-min) (point-max))
 309     (insert "\n" cipher))
 310   t)
 311
 312 ;;;###autoload
 313 (defun mml1991-encrypt (cont &optional sign)
 314   (let ((func (nth 2 (assq mml1991-use mml1991-function-alist))))
 315     (if func
 316         (funcall func cont sign)
 317       (error "Cannot find encrypt function"))))
 318
 319 ;;;###autoload
 320 (defun mml1991-sign (cont)
 321   (let ((func (nth 1 (assq mml1991-use mml1991-function-alist))))
 322     (if func
 323         (funcall func cont)
 324       (error "Cannot find sign function"))))
 325
 326 (provide 'mml1991)
 327
 328 ;; Local Variables:
 329 ;; coding: utf-8
 330 ;; End:
 331
 332 ;;; mml1991.el ends here