git.chise.org Git - elisp/gnus.git-/blob - lisp/pgg.el

   1 ;;; pgg.el --- glue for the various PGP implementations.
   2
   3 ;; Copyright (C) 1999, 2000, 2003 Free Software Foundation, Inc.
   4
   5 ;; Author: Daiki Ueno <ueno@unixuser.org>
   6 ;; Created: 1999/10/28
   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 2, or (at your option)
  14 ;; 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; see the file COPYING.  If not, write to the
  23 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  24 ;; Boston, MA 02111-1307, USA.
  25
  26 ;;; Commentary:
  27
  28 ;;; Code:
  29
  30 (require 'pgg-def)
  31 (require 'pgg-parse)
  32 (autoload 'run-at-time "timer")
  33
  34 ;; Don't merge these two `eval-when-compile's.
  35 (eval-when-compile
  36   (require 'cl))
  37 ;; Fixme: This would be better done with an autoload for
  38 ;; `url-insert-file-contents', and the url stuff rationalized.
  39 ;; (`locate-library' can say whether the url code is available.)
  40 (eval-when-compile
  41   (ignore-errors
  42     (require 'w3)
  43     (require 'url)))
  44
  45 ;; Fixme: Avoid this and use mm-make-temp-file (especially for
  46 ;; something sensitive like pgp).
  47 (defvar pgg-temporary-file-directory
  48   (cond ((fboundp 'temp-directory) (temp-directory))
  49         ((boundp 'temporary-file-directory) temporary-file-directory)
  50         ("/tmp/")))
  51
  52 ;;; @ utility functions
  53 ;;;
  54
  55 (defvar pgg-fetch-key-function (if (fboundp 'url-insert-file-contents)
  56                                    (function pgg-fetch-key-with-w3)))
  57
  58 (defun pgg-invoke (func scheme &rest args)
  59   (progn
  60     (require (intern (format "pgg-%s" scheme)))
  61     (apply 'funcall (intern (format "pgg-%s-%s" scheme func)) args)))
  62
  63 (put 'pgg-save-coding-system 'lisp-indent-function 2)
  64
  65 (defmacro pgg-save-coding-system (start end &rest body)
  66   `(if (interactive-p)
  67        (let ((buffer (current-buffer)))
  68          (with-temp-buffer
  69            (let (buffer-undo-list)
  70              (insert-buffer-substring buffer ,start ,end)
  71              (encode-coding-region (point-min)(point-max)
  72                                    buffer-file-coding-system)
  73              (prog1 (save-excursion ,@body)
  74                (push nil buffer-undo-list)
  75                (ignore-errors (undo))))))
  76      (save-restriction
  77        (narrow-to-region ,start ,end)
  78        ,@body)))
  79
  80 (defun pgg-temp-buffer-show-function (buffer)
  81   (let ((window (split-window-vertically)))
  82     (set-window-buffer window buffer)
  83     (shrink-window-if-larger-than-buffer window)))
  84
  85 (defun pgg-display-output-buffer (start end status)
  86   (if status
  87       (progn
  88         (delete-region start end)
  89         (insert-buffer-substring pgg-output-buffer)
  90         (decode-coding-region start (point) buffer-file-coding-system))
  91     (let ((temp-buffer-show-function
  92            (function pgg-temp-buffer-show-function)))
  93       (with-output-to-temp-buffer pgg-echo-buffer
  94         (set-buffer standard-output)
  95         (insert-buffer-substring pgg-errors-buffer)))))
  96
  97 (defvar pgg-passphrase-cache (make-vector 7 0))
  98
  99 (defun pgg-read-passphrase (prompt &optional key)
 100   (or (and pgg-cache-passphrase
 101            key (setq key (pgg-truncate-key-identifier key))
 102            (symbol-value (intern-soft key pgg-passphrase-cache)))
 103       (read-passwd prompt)))
 104
 105 (defun pgg-add-passphrase-cache (key passphrase)
 106   (setq key (pgg-truncate-key-identifier key))
 107   (set (intern key pgg-passphrase-cache)
 108        passphrase)
 109   (run-at-time pgg-passphrase-cache-expiry nil
 110                #'pgg-remove-passphrase-cache
 111                key))
 112
 113 (defun pgg-remove-passphrase-cache (key)
 114   (let ((passphrase (symbol-value (intern-soft key pgg-passphrase-cache))))
 115     (when passphrase
 116       (fillarray passphrase ?_)
 117       (unintern key pgg-passphrase-cache))))
 118
 119 (defmacro pgg-convert-lbt-region (start end lbt)
 120   `(let ((pgg-conversion-end (set-marker (make-marker) ,end)))
 121      (goto-char ,start)
 122      (case ,lbt
 123        (CRLF
 124         (while (progn
 125                  (end-of-line)
 126                  (> (marker-position pgg-conversion-end) (point)))
 127           (insert "\r")
 128           (forward-line 1)))
 129        (LF
 130         (while (re-search-forward "\r$" pgg-conversion-end t)
 131           (replace-match ""))))))
 132
 133 (put 'pgg-as-lbt 'lisp-indent-function 3)
 134
 135 (defmacro pgg-as-lbt (start end lbt &rest body)
 136   `(let ((inhibit-read-only t)
 137          buffer-read-only
 138          buffer-undo-list)
 139      (pgg-convert-lbt-region ,start ,end ,lbt)
 140      (let ((,end (point)))
 141        ,@body)
 142      (push nil buffer-undo-list)
 143      (ignore-errors (undo))))
 144
 145 (put 'pgg-process-when-success 'lisp-indent-function 0)
 146
 147 (defmacro pgg-process-when-success (&rest body)
 148   `(with-current-buffer pgg-output-buffer
 149      (if (zerop (buffer-size)) nil ,@body t)))
 150
 151 ;;; @ interface functions
 152 ;;;
 153
 154 ;;;###autoload
 155 (defun pgg-encrypt-region (start end rcpts &optional sign)
 156   "Encrypt the current region between START and END for RCPTS.
 157 If optional argument SIGN is non-nil, do a combined sign and encrypt."
 158   (interactive
 159    (list (region-beginning)(region-end)
 160          (split-string (read-string "Recipients: ") "[ \t,]+")))
 161   (let ((status
 162          (pgg-save-coding-system start end
 163            (pgg-invoke "encrypt-region" (or pgg-scheme pgg-default-scheme)
 164                        (point-min) (point-max) rcpts sign))))
 165     (when (interactive-p)
 166       (pgg-display-output-buffer start end status))
 167     status))
 168
 169 ;;;###autoload
 170 (defun pgg-encrypt (rcpts &optional sign start end)
 171   "Encrypt the current buffer for RCPTS.
 172 If optional argument SIGN is non-nil, do a combined sign and encrypt.
 173 If optional arguments START and END are specified, only encrypt within
 174 the region."
 175   (interactive (list (split-string (read-string "Recipients: ") "[ \t,]+")))
 176   (let* ((start (or start (point-min)))
 177          (end (or end (point-max)))
 178          (status (pgg-encrypt-region start end rcpts sign)))
 179     (when (interactive-p)
 180       (pgg-display-output-buffer start end status))
 181     status))
 182
 183 ;;;###autoload
 184 (defun pgg-decrypt-region (start end)
 185   "Decrypt the current region between START and END."
 186   (interactive "r")
 187   (let* ((buf (current-buffer))
 188          (packet (cdr (assq 1 (with-temp-buffer
 189                                 (insert-buffer-substring buf)
 190                                 (pgg-decode-armor-region
 191                                  (point-min) (point-max))))))
 192          (key (cdr (assq 'key-identifier packet)))
 193          (pgg-default-user-id
 194           (if key
 195               (concat "0x" (pgg-truncate-key-identifier key))
 196             pgg-default-user-id))
 197          (status
 198           (pgg-save-coding-system start end
 199             (pgg-invoke "decrypt-region" (or pgg-scheme pgg-default-scheme)
 200                         (point-min) (point-max)))))
 201     (when (interactive-p)
 202       (pgg-display-output-buffer start end status))
 203     status))
 204
 205 ;;;###autoload
 206 (defun pgg-decrypt (&optional start end)
 207   "Decrypt the current buffer.
 208 If optional arguments START and END are specified, only decrypt within
 209 the region."
 210   (interactive "")
 211   (let* ((start (or start (point-min)))
 212          (end (or end (point-max)))
 213          (status (pgg-decrypt-region start end)))
 214     (when (interactive-p)
 215       (pgg-display-output-buffer start end status))
 216     status))
 217
 218 ;;;###autoload
 219 (defun pgg-sign-region (start end &optional cleartext)
 220   "Make the signature from text between START and END.
 221 If the optional 3rd argument CLEARTEXT is non-nil, it does not create
 222 a detached signature.
 223 If this function is called interactively, CLEARTEXT is enabled
 224 and the the output is displayed."
 225   (interactive "r")
 226   (let ((status (pgg-save-coding-system start end
 227                   (pgg-invoke "sign-region" (or pgg-scheme pgg-default-scheme)
 228                               (point-min) (point-max)
 229                               (or (interactive-p) cleartext)))))
 230     (when (interactive-p)
 231       (pgg-display-output-buffer start end status))
 232     status))
 233
 234 ;;;###autoload
 235 (defun pgg-sign (&optional cleartext start end)
 236   "Sign the current buffer.
 237 If the optional argument CLEARTEXT is non-nil, it does not create a
 238 detached signature.
 239 If optional arguments START and END are specified, only sign data
 240 within the region.
 241 If this function is called interactively, CLEARTEXT is enabled
 242 and the the output is displayed."
 243   (interactive "")
 244   (let* ((start (or start (point-min)))
 245          (end (or end (point-max)))
 246          (status (pgg-sign-region start end (or (interactive-p) cleartext))))
 247     (when (interactive-p)
 248       (pgg-display-output-buffer start end status))
 249     status))
 250
 251 ;;;###autoload
 252 (defun pgg-verify-region (start end &optional signature fetch)
 253   "Verify the current region between START and END.
 254 If the optional 3rd argument SIGNATURE is non-nil, it is treated as
 255 the detached signature of the current region.
 256
 257 If the optional 4th argument FETCH is non-nil, we attempt to fetch the
 258 signer's public key from `pgg-default-keyserver-address'."
 259   (interactive "r")
 260   (let* ((packet
 261           (if (null signature) nil
 262             (with-temp-buffer
 263               (buffer-disable-undo)
 264               (if (fboundp 'set-buffer-multibyte)
 265                   (set-buffer-multibyte nil))
 266               (insert-file-contents signature)
 267               (cdr (assq 2 (pgg-decode-armor-region
 268                             (point-min)(point-max)))))))
 269          (key (cdr (assq 'key-identifier packet)))
 270          status keyserver)
 271     (and (stringp key)
 272          pgg-query-keyserver
 273          (setq key (concat "0x" (pgg-truncate-key-identifier key)))
 274          (null (pgg-lookup-key key))
 275          (or fetch (interactive-p))
 276          (y-or-n-p (format "Key %s not found; attempt to fetch? " key))
 277          (setq keyserver
 278                (or (cdr (assq 'preferred-key-server packet))
 279                    pgg-default-keyserver-address))
 280          (pgg-fetch-key keyserver key))
 281     (setq status
 282           (pgg-save-coding-system start end
 283             (pgg-invoke "verify-region" (or pgg-scheme pgg-default-scheme)
 284                         (point-min) (point-max) signature)))
 285     (when (interactive-p)
 286       (let ((temp-buffer-show-function
 287              (function pgg-temp-buffer-show-function)))
 288         (with-output-to-temp-buffer pgg-echo-buffer
 289           (set-buffer standard-output)
 290           (insert-buffer-substring (if status pgg-output-buffer
 291                                      pgg-errors-buffer)))))
 292     status))
 293
 294 ;;;###autoload
 295 (defun pgg-verify (&optional signature fetch start end)
 296   "Verify the current buffer.
 297 If the optional argument SIGNATURE is non-nil, it is treated as
 298 the detached signature of the current region.
 299 If the optional argument FETCH is non-nil, we attempt to fetch the
 300 signer's public key from `pgg-default-keyserver-address'.
 301 If optional arguments START and END are specified, only verify data
 302 within the region."
 303   (interactive "")
 304   (let* ((start (or start (point-min)))
 305          (end (or end (point-max)))
 306          (status (pgg-verify-region start end signature fetch)))
 307     (when (interactive-p)
 308       (let ((temp-buffer-show-function
 309              (function pgg-temp-buffer-show-function)))
 310         (with-output-to-temp-buffer pgg-echo-buffer
 311           (set-buffer standard-output)
 312           (insert-buffer-substring (if status pgg-output-buffer
 313                                      pgg-errors-buffer)))))))
 314
 315 ;;;###autoload
 316 (defun pgg-insert-key ()
 317   "Insert the ASCII armored public key."
 318   (interactive)
 319   (pgg-invoke "insert-key" (or pgg-scheme pgg-default-scheme)))
 320
 321 ;;;###autoload
 322 (defun pgg-snarf-keys-region (start end)
 323   "Import public keys in the current region between START and END."
 324   (interactive "r")
 325   (pgg-save-coding-system start end
 326     (pgg-invoke "snarf-keys-region" (or pgg-scheme pgg-default-scheme)
 327                 start end)))
 328
 329 ;;;###autoload
 330 (defun pgg-snarf-keys ()
 331   "Import public keys in the current buffer."
 332   (interactive "")
 333   (pgg-snarf-keys-region (point-min) (point-max)))
 334
 335 (defun pgg-lookup-key (string &optional type)
 336   (pgg-invoke "lookup-key" (or pgg-scheme pgg-default-scheme) string type))
 337
 338 (defvar pgg-insert-url-function  (function pgg-insert-url-with-w3))
 339
 340 (defun pgg-insert-url-with-w3 (url)
 341   (ignore-errors
 342     (require 'w3)
 343     (require 'url)
 344     (let (buffer-file-name)
 345       (url-insert-file-contents url))))
 346
 347 (defvar pgg-insert-url-extra-arguments nil)
 348 (defvar pgg-insert-url-program nil)
 349
 350 (defun pgg-insert-url-with-program (url)
 351   (let ((args (copy-sequence pgg-insert-url-extra-arguments))
 352         process)
 353     (insert
 354      (with-temp-buffer
 355        (setq process
 356              (apply #'start-process " *PGG url*" (current-buffer)
 357                     pgg-insert-url-program (nconc args (list url))))
 358        (set-process-sentinel process #'ignore)
 359        (while (eq 'run (process-status process))
 360          (accept-process-output process 5))
 361        (delete-process process)
 362        (if (and process (eq 'run (process-status process)))
 363            (interrupt-process process))
 364        (buffer-string)))))
 365
 366 (defun pgg-fetch-key (keyserver key)
 367   "Attempt to fetch a KEY from KEYSERVER for addition to PGP or GnuPG keyring."
 368   (with-current-buffer (get-buffer-create pgg-output-buffer)
 369     (buffer-disable-undo)
 370     (erase-buffer)
 371     (let ((proto (if (string-match "^[a-zA-Z\\+\\.\\\\-]+:" keyserver)
 372                      (substring keyserver 0 (1- (match-end 0))))))
 373       (save-excursion
 374         (funcall pgg-insert-url-function
 375                  (if proto keyserver
 376                    (format "http://%s:11371/pks/lookup?op=get&search=%s"
 377                            keyserver key))))
 378       (when (re-search-forward "^-+BEGIN" nil 'last)
 379         (delete-region (point-min) (match-beginning 0))
 380         (when (re-search-forward "^-+END" nil t)
 381           (delete-region (progn (end-of-line) (point))
 382                          (point-max)))
 383         (insert "\n")
 384         (with-temp-buffer
 385           (insert-buffer-substring pgg-output-buffer)
 386           (pgg-snarf-keys-region (point-min)(point-max)))))))
 387
 388
 389 (provide 'pgg)
 390
 391 ;;; pgg.el ends here