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