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