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