lisp/gnus/mml1991.el

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