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          (packet (cdr (assq 1 (with-temp-buffer
 196                                 (insert-buffer-substring buf)
 197                                 (pgg-decode-armor-region
 198                                  (point-min) (point-max))))))
 199          (key (cdr (assq 'key-identifier packet)))
 200          (pgg-default-user-id
 201           (if key
 202               (concat "0x" (pgg-truncate-key-identifier key))
 203             pgg-default-user-id))
 204          (status
 205           (pgg-save-coding-system start end
 206             (pgg-invoke "decrypt-region" (or pgg-scheme pgg-default-scheme)
 207                         (point-min) (point-max)))))
 208     (when (interactive-p)
 209       (pgg-display-output-buffer start end status))
 210     status))
 211
 212 ;;;###autoload
 213 (defun pgg-decrypt (&optional start end)
 214   "Decrypt the current buffer.
 215 If optional arguments START and END are specified, only decrypt within
 216 the region."
 217   (interactive "")
 218   (let* ((start (or start (point-min)))
 219          (end (or end (point-max)))
 220          (status (pgg-decrypt-region start end)))
 221     (when (interactive-p)
 222       (pgg-display-output-buffer start end status))
 223     status))
 224
 225 ;;;###autoload
 226 (defun pgg-sign-region (start end &optional cleartext)
 227   "Make the signature from text between START and END.
 228 If the optional 3rd argument CLEARTEXT is non-nil, it does not create
 229 a detached signature.
 230 If this function is called interactively, CLEARTEXT is enabled
 231 and the the output is displayed."
 232   (interactive "r")
 233   (let ((status (pgg-save-coding-system start end
 234                   (pgg-invoke "sign-region" (or pgg-scheme pgg-default-scheme)
 235                               (point-min) (point-max)
 236                               (or (interactive-p) cleartext)))))
 237     (when (interactive-p)
 238       (pgg-display-output-buffer start end status))
 239     status))
 240
 241 ;;;###autoload
 242 (defun pgg-sign (&optional cleartext start end)
 243   "Sign the current buffer.
 244 If the optional argument CLEARTEXT is non-nil, it does not create a
 245 detached signature.
 246 If optional arguments START and END are specified, only sign data
 247 within the region.
 248 If this function is called interactively, CLEARTEXT is enabled
 249 and the the output is displayed."
 250   (interactive "")
 251   (let* ((start (or start (point-min)))
 252          (end (or end (point-max)))
 253          (status (pgg-sign-region start end (or (interactive-p) cleartext))))
 254     (when (interactive-p)
 255       (pgg-display-output-buffer start end status))
 256     status))
 257
 258 ;;;###autoload
 259 (defun pgg-verify-region (start end &optional signature fetch)
 260   "Verify the current region between START and END.
 261 If the optional 3rd argument SIGNATURE is non-nil, it is treated as
 262 the detached signature of the current region.
 263
 264 If the optional 4th argument FETCH is non-nil, we attempt to fetch the
 265 signer's public key from `pgg-default-keyserver-address'."
 266   (interactive "r")
 267   (let* ((packet
 268           (if (null signature) nil
 269             (with-temp-buffer
 270               (buffer-disable-undo)
 271               (if (fboundp 'set-buffer-multibyte)
 272                   (set-buffer-multibyte nil))
 273               (insert-file-contents signature)
 274               (cdr (assq 2 (pgg-decode-armor-region
 275                             (point-min)(point-max)))))))
 276          (key (cdr (assq 'key-identifier packet)))
 277          status keyserver)
 278     (and (stringp key)
 279          pgg-query-keyserver
 280          (setq key (concat "0x" (pgg-truncate-key-identifier key)))
 281          (null (pgg-lookup-key key))
 282          (or fetch (interactive-p))
 283          (y-or-n-p (format "Key %s not found; attempt to fetch? " key))
 284          (setq keyserver
 285                (or (cdr (assq 'preferred-key-server packet))
 286                    pgg-default-keyserver-address))
 287          (pgg-fetch-key keyserver key))
 288     (setq status
 289           (pgg-save-coding-system start end
 290             (pgg-invoke "verify-region" (or pgg-scheme pgg-default-scheme)
 291                         (point-min) (point-max) signature)))
 292     (when (interactive-p)
 293       (let ((temp-buffer-show-function
 294              (function pgg-temp-buffer-show-function)))
 295         (with-output-to-temp-buffer pgg-echo-buffer
 296           (set-buffer standard-output)
 297           (insert-buffer-substring (if status pgg-output-buffer
 298                                      pgg-errors-buffer)))))
 299     status))
 300
 301 ;;;###autoload
 302 (defun pgg-verify (&optional signature fetch start end)
 303   "Verify the current buffer.
 304 If the optional argument SIGNATURE is non-nil, it is treated as
 305 the detached signature of the current region.
 306 If the optional argument FETCH is non-nil, we attempt to fetch the
 307 signer's public key from `pgg-default-keyserver-address'.
 308 If optional arguments START and END are specified, only verify data
 309 within the region."
 310   (interactive "")
 311   (let* ((start (or start (point-min)))
 312          (end (or end (point-max)))
 313          (status (pgg-verify-region start end signature fetch)))
 314     (when (interactive-p)
 315       (let ((temp-buffer-show-function
 316              (function pgg-temp-buffer-show-function)))
 317         (with-output-to-temp-buffer pgg-echo-buffer
 318           (set-buffer standard-output)
 319           (insert-buffer-substring (if status pgg-output-buffer
 320                                      pgg-errors-buffer)))))))
 321
 322 ;;;###autoload
 323 (defun pgg-insert-key ()
 324   "Insert the ASCII armored public key."
 325   (interactive)
 326   (pgg-invoke "insert-key" (or pgg-scheme pgg-default-scheme)))
 327
 328 ;;;###autoload
 329 (defun pgg-snarf-keys-region (start end)
 330   "Import public keys in the current region between START and END."
 331   (interactive "r")
 332   (pgg-save-coding-system start end
 333     (pgg-invoke "snarf-keys-region" (or pgg-scheme pgg-default-scheme)
 334                 start end)))
 335
 336 ;;;###autoload
 337 (defun pgg-snarf-keys ()
 338   "Import public keys in the current buffer."
 339   (interactive "")
 340   (pgg-snarf-keys-region (point-min) (point-max)))
 341
 342 (defun pgg-lookup-key (string &optional type)
 343   (pgg-invoke "lookup-key" (or pgg-scheme pgg-default-scheme) string type))
 344
 345 (defvar pgg-insert-url-function  (function pgg-insert-url-with-w3))
 346
 347 (defun pgg-insert-url-with-w3 (url)
 348   (ignore-errors
 349     (require 'w3)
 350     (require 'url)
 351     (let (buffer-file-name)
 352       (url-insert-file-contents url))))
 353
 354 (defvar pgg-insert-url-extra-arguments nil)
 355 (defvar pgg-insert-url-program nil)
 356
 357 (defun pgg-insert-url-with-program (url)
 358   (let ((args (copy-sequence pgg-insert-url-extra-arguments))
 359         process)
 360     (insert
 361      (with-temp-buffer
 362        (setq process
 363              (apply #'start-process " *PGG url*" (current-buffer)
 364                     pgg-insert-url-program (nconc args (list url))))
 365        (set-process-sentinel process #'ignore)
 366        (while (eq 'run (process-status process))
 367          (accept-process-output process 5))
 368        (delete-process process)
 369        (if (and process (eq 'run (process-status process)))
 370            (interrupt-process process))
 371        (buffer-string)))))
 372
 373 (defun pgg-fetch-key (keyserver key)
 374   "Attempt to fetch a KEY from KEYSERVER for addition to PGP or GnuPG keyring."
 375   (with-current-buffer (get-buffer-create pgg-output-buffer)
 376     (buffer-disable-undo)
 377     (erase-buffer)
 378     (let ((proto (if (string-match "^[a-zA-Z\\+\\.\\\\-]+:" keyserver)
 379                      (substring keyserver 0 (1- (match-end 0))))))
 380       (save-excursion
 381         (funcall pgg-insert-url-function
 382                  (if proto keyserver
 383                    (format "http://%s:11371/pks/lookup?op=get&search=%s"
 384                            keyserver key))))
 385       (when (re-search-forward "^-+BEGIN" nil 'last)
 386         (delete-region (point-min) (match-beginning 0))
 387         (when (re-search-forward "^-+END" nil t)
 388           (delete-region (progn (end-of-line) (point))
 389                          (point-max)))
 390         (insert "\n")
 391         (with-temp-buffer
 392           (insert-buffer-substring pgg-output-buffer)
 393           (pgg-snarf-keys-region (point-min)(point-max)))))))
 394
 395
 396 (provide 'pgg)
 397
 398 ;;; pgg.el ends here