cgit.sxemacs.org Git - gnus/blob - lisp/pgg.el

   1 ;;; pgg.el --- glue for the various PGP implementations.
   2
   3 ;; Copyright (C) 1999,2000 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 SEMI (Secure Emacs MIME Interface).
  10
  11 ;; This program is free software; you can redistribute it and/or
  12 ;; modify it under the terms of the GNU General Public License as
  13 ;; published by the Free Software Foundation; either version 2, or (at
  14 ;; your option) any later version.
  15
  16 ;; This program is distributed in the hope that it will be useful, but
  17 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  19 ;; 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
  27 ;;; Commentary:
  28 ;;
  29
  30 ;;; Code:
  31
  32 (require 'pgg-def)
  33 (require 'pgg-parse)
  34
  35 (eval-when-compile
  36   (require 'cl)
  37   (ignore-errors
  38     (require 'w3)
  39     (require 'url)))
  40
  41 (defvar pgg-temporary-file-directory
  42   (cond ((fboundp 'temp-directory) (temp-directory))
  43         ((boundp 'temporary-file-directory) temporary-file-directory)
  44         ("/tmp/")))
  45
  46 ;;; @ utility functions
  47 ;;;
  48
  49 (defvar pgg-fetch-key-function (if (fboundp 'url-insert-file-contents)
  50                                    (function pgg-fetch-key-with-w3)))
  51
  52 (defun pgg-invoke (func scheme &rest args)
  53   (progn
  54     (require (intern (format "pgg-%s" scheme)))
  55     (apply 'funcall (intern (format "pgg-%s-%s" scheme func)) args)))
  56
  57 (put 'pgg-save-coding-system 'lisp-indent-function 2)
  58
  59 (defmacro pgg-save-coding-system (start end &rest body)
  60   `(if (interactive-p)
  61        (let ((buffer (current-buffer)))
  62          (with-temp-buffer
  63            (let (buffer-undo-list)
  64              (insert-buffer-substring buffer ,start ,end)
  65              (encode-coding-region (point-min)(point-max)
  66                                    buffer-file-coding-system)
  67              (prog1 (save-excursion ,@body)
  68                (push nil buffer-undo-list)
  69                (ignore-errors (undo))))))
  70      (save-restriction
  71        (narrow-to-region ,start ,end)
  72        ,@body)))
  73
  74 (defun pgg-temp-buffer-show-function (buffer)
  75   (let ((window (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 ;;; @ interface functions
 146 ;;;
 147
 148 ;;;###autoload
 149 (defun pgg-encrypt-region (start end rcpts &optional sign)
 150   "Encrypt the current region between START and END for RCPTS.
 151 If optional argument SIGN is non-nil, do a combined sign and encrypt."
 152   (interactive
 153    (list (region-beginning)(region-end)
 154          (split-string (read-string "Recipients: ") "[ \t,]+")))
 155   (let ((status
 156          (pgg-save-coding-system start end
 157            (pgg-invoke "encrypt-region" (or pgg-scheme pgg-default-scheme)
 158                        (point-min) (point-max) rcpts sign))))
 159     (when (interactive-p)
 160       (pgg-display-output-buffer start end status))
 161     status))
 162
 163 ;;;###autoload
 164 (defun pgg-encrypt (rcpts &optional sign start end)
 165   "Encrypt the current buffer for RCPTS.
 166 If optional argument SIGN is non-nil, do a combined sign and encrypt.
 167 If optional arguments START and END are specified, only encrypt within
 168 the region."
 169   (interactive (list (split-string (read-string "Recipients: ") "[ \t,]+")))
 170   (let* ((start (or start (point-min)))
 171          (end (or end (point-max)))
 172          (status (pgg-encrypt-region start end rcpts sign)))
 173     (when (interactive-p)
 174       (pgg-display-output-buffer start end status))
 175     status))
 176
 177 ;;;###autoload
 178 (defun pgg-decrypt-region (start end)
 179   "Decrypt the current region between START and END."
 180   (interactive "r")
 181   (let* ((buf (current-buffer))
 182          (packet (cdr (assq 1 (with-temp-buffer
 183                                 (insert-buffer-substring buf)
 184                                 (pgg-decode-armor-region
 185                                  (point-min) (point-max))))))
 186          (key (cdr (assq 'key-identifier packet)))
 187          (pgg-default-user-id
 188           (if key
 189               (concat "0x" (pgg-truncate-key-identifier key))
 190             pgg-default-user-id))
 191          (status
 192           (pgg-save-coding-system start end
 193             (pgg-invoke "decrypt-region" (or pgg-scheme pgg-default-scheme)
 194                         (point-min) (point-max)))))
 195     (when (interactive-p)
 196       (pgg-display-output-buffer start end status))
 197     status))
 198
 199 ;;;###autoload
 200 (defun pgg-decrypt (&optional start end)
 201   "Decrypt the current buffer.
 202 If optional arguments START and END are specified, only decrypt within
 203 the region."
 204   (interactive "")
 205   (let* ((start (or start (point-min)))
 206          (end (or end (point-max)))
 207          (status (pgg-decrypt-region start end)))
 208     (when (interactive-p)
 209       (pgg-display-output-buffer start end status))
 210     status))
 211
 212 ;;;###autoload
 213 (defun pgg-sign-region (start end &optional cleartext)
 214   "Make the signature from text between START and END.
 215 If the optional 3rd argument CLEARTEXT is non-nil, it does not create
 216 a detached signature.
 217 If this function is called interactively, CLEARTEXT is enabled
 218 and the the output is displayed."
 219   (interactive "r")
 220   (let ((status (pgg-save-coding-system start end
 221                   (pgg-invoke "sign-region" (or pgg-scheme pgg-default-scheme)
 222                               (point-min) (point-max)
 223                               (or (interactive-p) cleartext)))))
 224     (when (interactive-p)
 225       (pgg-display-output-buffer start end status))
 226     status))
 227
 228 ;;;###autoload
 229 (defun pgg-sign (&optional cleartext start end)
 230   "Sign the current buffer.
 231 If the optional argument CLEARTEXT is non-nil, it does not create a
 232 detached signature.
 233 If optional arguments START and END are specified, only sign data
 234 within the region.
 235 If this function is called interactively, CLEARTEXT is enabled
 236 and the the output is displayed."
 237   (interactive "")
 238   (let* ((start (or start (point-min)))
 239          (end (or end (point-max)))
 240          (status (pgg-sign-region start end (or (interactive-p) cleartext))))
 241     (when (interactive-p)
 242       (pgg-display-output-buffer start end status))
 243     status))
 244
 245 ;;;###autoload
 246 (defun pgg-verify-region (start end &optional signature fetch)
 247   "Verify the current region between START and END.
 248 If the optional 3rd argument SIGNATURE is non-nil, it is treated as
 249 the detached signature of the current region.
 250
 251 If the optional 4th argument FETCH is non-nil, we attempt to fetch the
 252 signer's public key from `pgg-default-keyserver-address'."
 253   (interactive "r")
 254   (let* ((packet
 255           (if (null signature) nil
 256             (with-temp-buffer
 257               (buffer-disable-undo)
 258               (if (fboundp 'set-buffer-multibyte)
 259                   (set-buffer-multibyte nil))
 260               (insert-file-contents signature)
 261               (cdr (assq 2 (pgg-decode-armor-region
 262                             (point-min)(point-max)))))))
 263          (key (cdr (assq 'key-identifier packet)))
 264          status keyserver)
 265     (and (stringp key)
 266          pgg-query-keyserver
 267          (setq key (concat "0x" (pgg-truncate-key-identifier key)))
 268          (null (pgg-lookup-key key))
 269          (or fetch (interactive-p))
 270          (y-or-n-p (format "Key %s not found; attempt to fetch? " key))
 271          (setq keyserver
 272                (or (cdr (assq 'preferred-key-server packet))
 273                    pgg-default-keyserver-address))
 274          (pgg-fetch-key keyserver key))
 275     (setq status
 276           (pgg-save-coding-system start end
 277             (pgg-invoke "verify-region" (or pgg-scheme pgg-default-scheme)
 278                         (point-min) (point-max) signature)))
 279     (when (interactive-p)
 280       (let ((temp-buffer-show-function
 281              (function pgg-temp-buffer-show-function)))
 282         (with-output-to-temp-buffer pgg-echo-buffer
 283           (set-buffer standard-output)
 284           (insert-buffer-substring (if status pgg-output-buffer
 285                                      pgg-errors-buffer)))))
 286     status))
 287
 288 ;;;###autoload
 289 (defun pgg-verify (&optional signature fetch start end)
 290   "Verify the current buffer.
 291 If the optional argument SIGNATURE is non-nil, it is treated as
 292 the detached signature of the current region.
 293 If the optional argument FETCH is non-nil, we attempt to fetch the
 294 signer's public key from `pgg-default-keyserver-address'.
 295 If optional arguments START and END are specified, only verify data
 296 within the region."
 297   (interactive "")
 298   (let* ((start (or start (point-min)))
 299          (end (or end (point-max)))
 300          (status (pgg-verify-region start end signature fetch)))
 301     (when (interactive-p)
 302       (let ((temp-buffer-show-function
 303              (function pgg-temp-buffer-show-function)))
 304         (with-output-to-temp-buffer pgg-echo-buffer
 305           (set-buffer standard-output)
 306           (insert-buffer-substring (if status pgg-output-buffer
 307                                      pgg-errors-buffer)))))))
 308
 309 ;;;###autoload
 310 (defun pgg-insert-key ()
 311   "Insert the ASCII armored public key."
 312   (interactive)
 313   (pgg-invoke "insert-key" (or pgg-scheme pgg-default-scheme)))
 314
 315 ;;;###autoload
 316 (defun pgg-snarf-keys-region (start end)
 317   "Import public keys in the current region between START and END."
 318   (interactive "r")
 319   (pgg-save-coding-system start end
 320     (pgg-invoke "snarf-keys-region" (or pgg-scheme pgg-default-scheme)
 321                 start end)))
 322
 323 ;;;###autoload
 324 (defun pgg-snarf-keys ()
 325   "Import public keys in the current buffer."
 326   (interactive "")
 327   (pgg-snarf-keys-region (point-min) (point-max)))
 328
 329 (defun pgg-lookup-key (string &optional type)
 330   (pgg-invoke "lookup-key" (or pgg-scheme pgg-default-scheme) string type))
 331
 332 (defvar pgg-insert-url-function  (function pgg-insert-url-with-w3))
 333
 334 (defun pgg-insert-url-with-w3 (url)
 335   (ignore-errors
 336     (require 'w3)
 337     (require 'url)
 338     (let (buffer-file-name)
 339       (url-insert-file-contents url))))
 340
 341 (defvar pgg-insert-url-extra-arguments nil)
 342 (defvar pgg-insert-url-program nil)
 343
 344 (defun pgg-insert-url-with-program (url)
 345   (let ((args (copy-sequence pgg-insert-url-extra-arguments))
 346         process)
 347     (insert
 348      (with-temp-buffer
 349        (setq process
 350              (apply #'start-process " *PGG url*" (current-buffer)
 351                     pgg-insert-url-program (nconc args (list url))))
 352        (set-process-sentinel process #'ignore)
 353        (while (eq 'run (process-status process))
 354          (accept-process-output process 5))
 355        (delete-process process)
 356        (if (and process (eq 'run (process-status process)))
 357            (interrupt-process process))
 358        (buffer-string)))))
 359
 360 (defun pgg-fetch-key (keyserver key)
 361   "Attempt to fetch a KEY from KEYSERVER for addition to PGP or GnuPG keyring."
 362   (with-current-buffer (get-buffer-create pgg-output-buffer)
 363     (buffer-disable-undo)
 364     (erase-buffer)
 365     (let ((proto (if (string-match "^[a-zA-Z\\+\\.\\\\-]+:" keyserver)
 366                      (substring keyserver 0 (1- (match-end 0))))))
 367       (save-excursion
 368         (funcall pgg-insert-url-function
 369                  (if proto keyserver
 370                    (format "http://%s:11371/pks/lookup?op=get&search=%s"
 371                            keyserver key))))
 372       (when (re-search-forward "^-+BEGIN" nil 'last)
 373         (delete-region (point-min) (match-beginning 0))
 374         (when (re-search-forward "^-+END" nil t)
 375           (delete-region (progn (end-of-line) (point))
 376                          (point-max)))
 377         (insert "\n")
 378         (with-temp-buffer
 379           (insert-buffer-substring pgg-output-buffer)
 380           (pgg-snarf-keys-region (point-min)(point-max)))))))
 381
 382
 383 (provide 'pgg)
 384
 385 ;;; pgg.el ends here