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