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