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-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     (mm-with-unibyte-current-buffer
 199       (insert-buffer-substring pgg-output-buffer)
 200       (goto-char (point-min))
 201       (while (re-search-forward "\r+$" nil t)
 202         (replace-match "" t t))
 203       (when cte
 204         (mm-encode-content-transfer-encoding cte))
 205       (goto-char (point-min))
 206       (when headers
 207         (insert headers))
 208       (insert "\n"))
 209     t))
 210
 211 (defun mml1991-pgg-encrypt (cont &optional sign)
 212   (goto-char (point-min))
 213   (when (re-search-forward "^$" nil t)
 214     (let ((cte (save-restriction
 215                  (narrow-to-region (point-min) (point))
 216                  (mail-fetch-field "content-transfer-encoding"))))
 217       ;; Strip MIME headers since it will be ASCII armored.
 218       (forward-line 1)
 219       (delete-region (point-min) (point))
 220       (when cte
 221         (mm-decode-content-transfer-encoding (intern (downcase cte))))))
 222   (unless (let ((pgg-text-mode t))
 223             (pgg-encrypt-region
 224              (point-min) (point-max)
 225              (split-string
 226               (or
 227                (message-options-get 'message-recipients)
 228                (message-options-set 'message-recipients
 229                                     (read-string "Recipients: ")))
 230               "[ \f\t\n\r\v,]+")
 231              sign))
 232     (pop-to-buffer pgg-errors-buffer)
 233     (error "Encrypt error"))
 234   (delete-region (point-min) (point-max))
 235   (insert "\n")
 236   (insert-buffer-substring pgg-output-buffer)
 237   t)
 238
 239 ;; epg wrapper
 240
 241 (defvar epg-user-id-alist)
 242
 243 (autoload 'epg-make-context "epg")
 244 (autoload 'epg-passphrase-callback-function "epg")
 245 (autoload 'epa-select-keys "epa")
 246 (autoload 'epg-list-keys "epg")
 247 (autoload 'epg-context-set-armor "epg")
 248 (autoload 'epg-context-set-textmode "epg")
 249 (autoload 'epg-context-set-signers "epg")
 250 (autoload 'epg-context-set-passphrase-callback "epg")
 251 (autoload 'epg-key-sub-key-list "epg")
 252 (autoload 'epg-sub-key-capability "epg")
 253 (autoload 'epg-sub-key-validity "epg")
 254 (autoload 'epg-sub-key-fingerprint "epg")
 255 (autoload 'epg-sign-string "epg")
 256 (autoload 'epg-encrypt-string "epg")
 257 (autoload 'epg-configuration "epg-config")
 258 (autoload 'epg-expand-group "epg-config")
 259
 260 (defun mml1991-epg-sign (cont)
 261   (let ((inhibit-redisplay t)
 262         headers cte)
 263     ;; Don't sign headers.
 264     (goto-char (point-min))
 265     (when (re-search-forward "^$" nil t)
 266       (setq headers (buffer-substring (point-min) (point)))
 267       (save-restriction
 268         (narrow-to-region (point-min) (point))
 269         (setq cte (mail-fetch-field "content-transfer-encoding")))
 270       (forward-line 1)
 271       (delete-region (point-min) (point))
 272       (when cte
 273         (setq cte (intern (downcase cte)))
 274         (mm-decode-content-transfer-encoding cte)))
 275     (let* ((pair (mml-secure-epg-sign 'OpenPGP 'clear))
 276            (signature (car pair)))
 277       (delete-region (point-min) (point-max))
 278       (mm-with-unibyte-current-buffer
 279         (insert signature)
 280         (goto-char (point-min))
 281         (while (re-search-forward "\r+$" nil t)
 282           (replace-match "" t t))
 283         (when cte
 284           (mm-encode-content-transfer-encoding cte))
 285         (goto-char (point-min))
 286         (when headers
 287           (insert headers))
 288         (insert "\n"))
 289       t)))
 290
 291 (defun mml1991-epg-encrypt (cont &optional sign)
 292   (goto-char (point-min))
 293   (when (re-search-forward "^$" nil t)
 294     (let ((cte (save-restriction
 295                  (narrow-to-region (point-min) (point))
 296                  (mail-fetch-field "content-transfer-encoding"))))
 297       ;; Strip MIME headers since it will be ASCII armored.
 298       (forward-line 1)
 299       (delete-region (point-min) (point))
 300       (when cte
 301         (mm-decode-content-transfer-encoding (intern (downcase cte))))))
 302   (let ((cipher (mml-secure-epg-encrypt 'OpenPGP cont sign)))
 303     (delete-region (point-min) (point-max))
 304     (insert "\n" cipher))
 305   t)
 306
 307 ;;;###autoload
 308 (defun mml1991-encrypt (cont &optional sign)
 309   (let ((func (nth 2 (assq mml1991-use mml1991-function-alist))))
 310     (if func
 311         (funcall func cont sign)
 312       (error "Cannot find encrypt function"))))
 313
 314 ;;;###autoload
 315 (defun mml1991-sign (cont)
 316   (let ((func (nth 1 (assq mml1991-use mml1991-function-alist))))
 317     (if func
 318         (funcall func cont)
 319       (error "Cannot find sign function"))))
 320
 321 (provide 'mml1991)
 322
 323 ;; Local Variables:
 324 ;; coding: utf-8
 325 ;; End:
 326
 327 ;;; mml1991.el ends here