lisp/gnus/pgg.el

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