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