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