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 ;;; @ utility functions
  46 ;;;
  47
  48 (defvar pgg-fetch-key-function (if (fboundp 'url-insert-file-contents)
  49                                    (function pgg-fetch-key-with-w3)))
  50
  51 (defun pgg-invoke (func scheme &rest args)
  52   (progn
  53     (require (intern (format "pgg-%s" scheme)))
  54     (apply 'funcall (intern (format "pgg-%s-%s" scheme func)) args)))
  55
  56 (put 'pgg-save-coding-system 'lisp-indent-function 2)
  57
  58 (defmacro pgg-save-coding-system (start end &rest body)
  59   `(if (interactive-p)
  60        (let ((buffer (current-buffer)))
  61          (with-temp-buffer
  62            (let (buffer-undo-list)
  63              (insert-buffer-substring buffer ,start ,end)
  64              (encode-coding-region (point-min)(point-max)
  65                                    buffer-file-coding-system)
  66              (prog1 (save-excursion ,@body)
  67                (push nil buffer-undo-list)
  68                (ignore-errors (undo))))))
  69      (save-restriction
  70        (narrow-to-region ,start ,end)
  71        ,@body)))
  72
  73 (defun pgg-temp-buffer-show-function (buffer)
  74   (let ((window (or (get-buffer-window buffer 'visible)
  75                     (split-window-vertically))))
  76     (set-window-buffer window buffer)
  77     (shrink-window-if-larger-than-buffer window)))
  78
  79 (defun pgg-display-output-buffer (start end status)
  80   (if status
  81       (progn
  82         (delete-region start end)
  83         (insert-buffer-substring pgg-output-buffer)
  84         (decode-coding-region start (point) buffer-file-coding-system))
  85     (let ((temp-buffer-show-function
  86            (function pgg-temp-buffer-show-function)))
  87       (with-output-to-temp-buffer pgg-echo-buffer
  88         (set-buffer standard-output)
  89         (insert-buffer-substring pgg-errors-buffer)))))
  90
  91 (defvar pgg-passphrase-cache (make-vector 7 0))
  92
  93 (defun pgg-read-passphrase (prompt &optional key)
  94   (or (and pgg-cache-passphrase
  95            key (setq key (pgg-truncate-key-identifier key))
  96            (symbol-value (intern-soft key pgg-passphrase-cache)))
  97       (read-passwd prompt)))
  98
  99 (eval-when-compile
 100   (defvar itimer-process)
 101   (defvar itimer-timer)
 102   (autoload 'delete-itimer "itimer")
 103   (autoload 'itimer-driver-start "itimer")
 104   (autoload 'itimer-value "itimer")
 105   (autoload 'set-itimer-function "itimer")
 106   (autoload 'set-itimer-function-arguments "itimer")
 107   (autoload 'set-itimer-restart "itimer")
 108   (autoload 'start-itimer "itimer"))
 109
 110 (eval-and-compile
 111   (defalias
 112     'pgg-run-at-time
 113     (if (featurep 'xemacs)
 114         (if (condition-case nil
 115                 (progn
 116                   (unless (or itimer-process itimer-timer)
 117                     (itimer-driver-start))
 118                   ;; Check whether there is a bug to which the difference of
 119                   ;; the present time and the time when the itimer driver was
 120                   ;; woken up is subtracted from the initial itimer value.
 121                   (let* ((inhibit-quit t)
 122                          (ctime (current-time))
 123                          (itimer-timer-last-wakeup
 124                           (prog1
 125                               ctime
 126                             (setcar ctime (1- (car ctime)))))
 127                          (itimer-list nil)
 128                          (itimer (start-itimer "pgg-run-at-time" 'ignore 5)))
 129                     (sleep-for 0.1) ;; Accept the timeout interrupt.
 130                     (prog1
 131                         (> (itimer-value itimer) 0)
 132                       (delete-itimer itimer))))
 133               (error nil))
 134             (lambda (time repeat function &rest args)
 135               "Emulating function run as `run-at-time'.
 136 TIME should be nil meaning now, or a number of seconds from now.
 137 Return an itimer object which can be used in either `delete-itimer'
 138 or `cancel-timer'."
 139               (apply #'start-itimer "pgg-run-at-time"
 140                      function (if time (max time 1e-9) 1e-9)
 141                      repeat nil t args))
 142           (lambda (time repeat function &rest args)
 143             "Emulating function run as `run-at-time' in the right way.
 144 TIME should be nil meaning now, or a number of seconds from now.
 145 Return an itimer object which can be used in either `delete-itimer'
 146 or `cancel-timer'."
 147             (let ((itimers (list nil)))
 148               (setcar
 149                itimers
 150                (apply #'start-itimer "pgg-run-at-time"
 151                       (lambda (itimers repeat function &rest args)
 152                         (let ((itimer (car itimers)))
 153                           (if repeat
 154                               (progn
 155                                 (set-itimer-function
 156                                  itimer
 157                                  (lambda (itimer repeat function &rest args)
 158                                    (set-itimer-restart itimer repeat)
 159                                    (set-itimer-function itimer function)
 160                                    (set-itimer-function-arguments itimer args)
 161                                    (apply function args)))
 162                                 (set-itimer-function-arguments
 163                                  itimer
 164                                  (append (list itimer repeat function) args)))
 165                             (set-itimer-function
 166                              itimer
 167                              (lambda (itimer function &rest args)
 168                                (delete-itimer itimer)
 169                                (apply function args)))
 170                             (set-itimer-function-arguments
 171                              itimer
 172                              (append (list itimer function) args)))))
 173                       1e-9 (if time (max time 1e-9) 1e-9)
 174                       nil t itimers repeat function args)))))
 175       'run-at-time)))
 176
 177 (defun pgg-add-passphrase-cache (key passphrase)
 178   (setq key (pgg-truncate-key-identifier key))
 179   (set (intern key pgg-passphrase-cache)
 180        passphrase)
 181   (pgg-run-at-time pgg-passphrase-cache-expiry nil
 182                    #'pgg-remove-passphrase-cache
 183                    key))
 184
 185 (defun pgg-remove-passphrase-cache (key)
 186   (let ((passphrase (symbol-value (intern-soft key pgg-passphrase-cache))))
 187     (when passphrase
 188       (fillarray passphrase ?_)
 189       (unintern key pgg-passphrase-cache))))
 190
 191 (defmacro pgg-convert-lbt-region (start end lbt)
 192   `(let ((pgg-conversion-end (set-marker (make-marker) ,end)))
 193      (goto-char ,start)
 194      (case ,lbt
 195        (CRLF
 196         (while (progn
 197                  (end-of-line)
 198                  (> (marker-position pgg-conversion-end) (point)))
 199           (insert "\r")
 200           (forward-line 1)))
 201        (LF
 202         (while (re-search-forward "\r$" pgg-conversion-end t)
 203           (replace-match ""))))))
 204
 205 (put 'pgg-as-lbt 'lisp-indent-function 3)
 206
 207 (defmacro pgg-as-lbt (start end lbt &rest body)
 208   `(let ((inhibit-read-only t)
 209          buffer-read-only
 210          buffer-undo-list)
 211      (pgg-convert-lbt-region ,start ,end ,lbt)
 212      (let ((,end (point)))
 213        ,@body)
 214      (push nil buffer-undo-list)
 215      (ignore-errors (undo))))
 216
 217 (put 'pgg-process-when-success 'lisp-indent-function 0)
 218
 219 (defmacro pgg-process-when-success (&rest body)
 220   `(with-current-buffer pgg-output-buffer
 221      (if (zerop (buffer-size)) nil ,@body t)))
 222
 223 (defalias 'pgg-make-temp-file
 224   (if (fboundp 'make-temp-file)
 225       'make-temp-file
 226     (lambda (prefix &optional dir-flag)
 227       (let ((file (expand-file-name
 228                    (make-temp-name prefix)
 229                    (if (fboundp 'temp-directory)
 230                        (temp-directory)
 231                      temporary-file-directory))))
 232         (if dir-flag
 233             (make-directory file))
 234         file))))
 235
 236 ;;; @ interface functions
 237 ;;;
 238
 239 ;;;###autoload
 240 (defun pgg-encrypt-region (start end rcpts &optional sign)
 241   "Encrypt the current region between START and END for RCPTS.
 242 If optional argument SIGN is non-nil, do a combined sign and encrypt."
 243   (interactive
 244    (list (region-beginning)(region-end)
 245          (split-string (read-string "Recipients: ") "[ \t,]+")))
 246   (let ((status
 247          (pgg-save-coding-system start end
 248            (pgg-invoke "encrypt-region" (or pgg-scheme pgg-default-scheme)
 249                        (point-min) (point-max) rcpts sign))))
 250     (when (interactive-p)
 251       (pgg-display-output-buffer start end status))
 252     status))
 253
 254 ;;;###autoload
 255 (defun pgg-encrypt (rcpts &optional sign start end)
 256   "Encrypt the current buffer for RCPTS.
 257 If optional argument SIGN is non-nil, do a combined sign and encrypt.
 258 If optional arguments START and END are specified, only encrypt within
 259 the region."
 260   (interactive (list (split-string (read-string "Recipients: ") "[ \t,]+")))
 261   (let* ((start (or start (point-min)))
 262          (end (or end (point-max)))
 263          (status (pgg-encrypt-region start end rcpts sign)))
 264     (when (interactive-p)
 265       (pgg-display-output-buffer start end status))
 266     status))
 267
 268 ;;;###autoload
 269 (defun pgg-decrypt-region (start end)
 270   "Decrypt the current region between START and END."
 271   (interactive "r")
 272   (let* ((buf (current-buffer))
 273          (status
 274           (pgg-save-coding-system start end
 275             (pgg-invoke "decrypt-region" (or pgg-scheme pgg-default-scheme)
 276                         (point-min) (point-max)))))
 277     (when (interactive-p)
 278       (pgg-display-output-buffer start end status))
 279     status))
 280
 281 ;;;###autoload
 282 (defun pgg-decrypt (&optional start end)
 283   "Decrypt the current buffer.
 284 If optional arguments START and END are specified, only decrypt within
 285 the region."
 286   (interactive "")
 287   (let* ((start (or start (point-min)))
 288          (end (or end (point-max)))
 289          (status (pgg-decrypt-region start end)))
 290     (when (interactive-p)
 291       (pgg-display-output-buffer start end status))
 292     status))
 293
 294 ;;;###autoload
 295 (defun pgg-sign-region (start end &optional cleartext)
 296   "Make the signature from text between START and END.
 297 If the optional 3rd argument CLEARTEXT is non-nil, it does not create
 298 a detached signature.
 299 If this function is called interactively, CLEARTEXT is enabled
 300 and the the output is displayed."
 301   (interactive "r")
 302   (let ((status (pgg-save-coding-system start end
 303                   (pgg-invoke "sign-region" (or pgg-scheme pgg-default-scheme)
 304                               (point-min) (point-max)
 305                               (or (interactive-p) cleartext)))))
 306     (when (interactive-p)
 307       (pgg-display-output-buffer start end status))
 308     status))
 309
 310 ;;;###autoload
 311 (defun pgg-sign (&optional cleartext start end)
 312   "Sign the current buffer.
 313 If the optional argument CLEARTEXT is non-nil, it does not create a
 314 detached signature.
 315 If optional arguments START and END are specified, only sign data
 316 within the region.
 317 If this function is called interactively, CLEARTEXT is enabled
 318 and the the output is displayed."
 319   (interactive "")
 320   (let* ((start (or start (point-min)))
 321          (end (or end (point-max)))
 322          (status (pgg-sign-region start end (or (interactive-p) cleartext))))
 323     (when (interactive-p)
 324       (pgg-display-output-buffer start end status))
 325     status))
 326
 327 ;;;###autoload
 328 (defun pgg-verify-region (start end &optional signature fetch)
 329   "Verify the current region between START and END.
 330 If the optional 3rd argument SIGNATURE is non-nil, it is treated as
 331 the detached signature of the current region.
 332
 333 If the optional 4th argument FETCH is non-nil, we attempt to fetch the
 334 signer's public key from `pgg-default-keyserver-address'."
 335   (interactive "r")
 336   (let* ((packet
 337           (if (null signature) nil
 338             (with-temp-buffer
 339               (buffer-disable-undo)
 340               (if (fboundp 'set-buffer-multibyte)
 341                   (set-buffer-multibyte nil))
 342               (insert-file-contents signature)
 343               (cdr (assq 2 (pgg-decode-armor-region
 344                             (point-min)(point-max)))))))
 345          (key (cdr (assq 'key-identifier packet)))
 346          status keyserver)
 347     (and (stringp key)
 348          pgg-query-keyserver
 349          (setq key (concat "0x" (pgg-truncate-key-identifier key)))
 350          (null (pgg-lookup-key key))
 351          (or fetch (interactive-p))
 352          (y-or-n-p (format "Key %s not found; attempt to fetch? " key))
 353          (setq keyserver
 354                (or (cdr (assq 'preferred-key-server packet))
 355                    pgg-default-keyserver-address))
 356          (pgg-fetch-key keyserver key))
 357     (setq status
 358           (pgg-save-coding-system start end
 359             (pgg-invoke "verify-region" (or pgg-scheme pgg-default-scheme)
 360                         (point-min) (point-max) signature)))
 361     (when (interactive-p)
 362       (let ((temp-buffer-show-function
 363              (function pgg-temp-buffer-show-function)))
 364         (with-output-to-temp-buffer pgg-echo-buffer
 365           (set-buffer standard-output)
 366           (insert-buffer-substring (if status pgg-output-buffer
 367                                      pgg-errors-buffer)))))
 368     status))
 369
 370 ;;;###autoload
 371 (defun pgg-verify (&optional signature fetch start end)
 372   "Verify the current buffer.
 373 If the optional argument SIGNATURE is non-nil, it is treated as
 374 the detached signature of the current region.
 375 If the optional argument FETCH is non-nil, we attempt to fetch the
 376 signer's public key from `pgg-default-keyserver-address'.
 377 If optional arguments START and END are specified, only verify data
 378 within the region."
 379   (interactive "")
 380   (let* ((start (or start (point-min)))
 381          (end (or end (point-max)))
 382          (status (pgg-verify-region start end signature fetch)))
 383     (when (interactive-p)
 384       (let ((temp-buffer-show-function
 385              (function pgg-temp-buffer-show-function)))
 386         (with-output-to-temp-buffer pgg-echo-buffer
 387           (set-buffer standard-output)
 388           (insert-buffer-substring (if status pgg-output-buffer
 389                                      pgg-errors-buffer)))))))
 390
 391 ;;;###autoload
 392 (defun pgg-insert-key ()
 393   "Insert the ASCII armored public key."
 394   (interactive)
 395   (pgg-invoke "insert-key" (or pgg-scheme pgg-default-scheme)))
 396
 397 ;;;###autoload
 398 (defun pgg-snarf-keys-region (start end)
 399   "Import public keys in the current region between START and END."
 400   (interactive "r")
 401   (pgg-save-coding-system start end
 402     (pgg-invoke "snarf-keys-region" (or pgg-scheme pgg-default-scheme)
 403                 start end)))
 404
 405 ;;;###autoload
 406 (defun pgg-snarf-keys ()
 407   "Import public keys in the current buffer."
 408   (interactive "")
 409   (pgg-snarf-keys-region (point-min) (point-max)))
 410
 411 (defun pgg-lookup-key (string &optional type)
 412   (pgg-invoke "lookup-key" (or pgg-scheme pgg-default-scheme) string type))
 413
 414 (defvar pgg-insert-url-function  (function pgg-insert-url-with-w3))
 415
 416 (defun pgg-insert-url-with-w3 (url)
 417   (ignore-errors
 418     (require 'w3)
 419     (require 'url)
 420     (let (buffer-file-name)
 421       (url-insert-file-contents url))))
 422
 423 (defvar pgg-insert-url-extra-arguments nil)
 424 (defvar pgg-insert-url-program nil)
 425
 426 (defun pgg-insert-url-with-program (url)
 427   (let ((args (copy-sequence pgg-insert-url-extra-arguments))
 428         process)
 429     (insert
 430      (with-temp-buffer
 431        (setq process
 432              (apply #'start-process " *PGG url*" (current-buffer)
 433                     pgg-insert-url-program (nconc args (list url))))
 434        (set-process-sentinel process #'ignore)
 435        (while (eq 'run (process-status process))
 436          (accept-process-output process 5))
 437        (delete-process process)
 438        (if (and process (eq 'run (process-status process)))
 439            (interrupt-process process))
 440        (buffer-string)))))
 441
 442 (defun pgg-fetch-key (keyserver key)
 443   "Attempt to fetch a KEY from KEYSERVER for addition to PGP or GnuPG keyring."
 444   (with-current-buffer (get-buffer-create pgg-output-buffer)
 445     (buffer-disable-undo)
 446     (erase-buffer)
 447     (let ((proto (if (string-match "^[a-zA-Z\\+\\.\\\\-]+:" keyserver)
 448                      (substring keyserver 0 (1- (match-end 0))))))
 449       (save-excursion
 450         (funcall pgg-insert-url-function
 451                  (if proto keyserver
 452                    (format "http://%s:11371/pks/lookup?op=get&search=%s"
 453                            keyserver key))))
 454       (when (re-search-forward "^-+BEGIN" nil 'last)
 455         (delete-region (point-min) (match-beginning 0))
 456         (when (re-search-forward "^-+END" nil t)
 457           (delete-region (progn (end-of-line) (point))
 458                          (point-max)))
 459         (insert "\n")
 460         (with-temp-buffer
 461           (insert-buffer-substring pgg-output-buffer)
 462           (pgg-snarf-keys-region (point-min)(point-max)))))))
 463
 464
 465 (provide 'pgg)
 466
 467 ;;; pgg.el ends here