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

   1 ;;; pgg-pgp.el --- PGP 2.* and 6.* support for PGG.
   2
   3 ;; Copyright (C) 1999, 2000, 2002, 2003, 2004,
   4 ;;   2005, 2006 Free Software Foundation, Inc.
   5
   6 ;; Author: Daiki Ueno <ueno@unixuser.org>
   7 ;; Created: 1999/11/02
   8 ;; Keywords: PGP, OpenPGP
   9
  10 ;; This file is part of GNU Emacs.
  11
  12 ;; GNU Emacs is free software; you can redistribute it and/or modify
  13 ;; it under the terms of the GNU General Public License as published by
  14 ;; the Free Software Foundation; either version 2, or (at your option)
  15 ;; any later version.
  16
  17 ;; GNU Emacs is distributed in the hope that it will be useful,
  18 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  20 ;; GNU General Public License for more details.
  21
  22 ;; You should have received a copy of the GNU General Public License
  23 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  24 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  25 ;; Boston, MA 02110-1301, USA.
  26
  27 ;;; Code:
  28
  29 (eval-when-compile
  30   (require 'cl)                         ; for pgg macros
  31   (require 'pgg))
  32
  33 (defgroup pgg-pgp ()
  34   "PGP 2.* and 6.* interface."
  35   :group 'pgg)
  36
  37 (defcustom pgg-pgp-program "pgp"
  38   "PGP 2.* and 6.* executable."
  39   :group 'pgg-pgp
  40   :type 'string)
  41
  42 (defcustom pgg-pgp-shell-file-name "/bin/sh"
  43   "File name to load inferior shells from.
  44 Bourne shell or its equivalent \(not tcsh) is needed for \"2>\"."
  45   :group 'pgg-pgp
  46   :type 'string)
  47
  48 (defcustom pgg-pgp-shell-command-switch "-c"
  49   "Switch used to have the shell execute its command line argument."
  50   :group 'pgg-pgp
  51   :type 'string)
  52
  53 (defcustom pgg-pgp-extra-args nil
  54   "Extra arguments for every PGP invocation."
  55   :group 'pgg-pgp
  56   :type '(choice
  57           (const :tag "None" nil)
  58           (string :tag "Arguments")))
  59
  60 (defvar pgg-pgp-user-id nil
  61   "PGP ID of your default identity.")
  62
  63 (defun pgg-pgp-process-region (start end passphrase program args)
  64   (let* ((errors-file-name (pgg-make-temp-file "pgg-errors"))
  65          (args
  66           (append args
  67                   pgg-pgp-extra-args
  68                   (list (concat "2>" errors-file-name))))
  69          (shell-file-name pgg-pgp-shell-file-name)
  70          (shell-command-switch pgg-pgp-shell-command-switch)
  71          (process-environment process-environment)
  72          (output-buffer pgg-output-buffer)
  73          (errors-buffer pgg-errors-buffer)
  74          (process-connection-type nil)
  75          process status exit-status)
  76     (with-current-buffer (let ((default-enable-multibyte-characters t))
  77                            (get-buffer-create output-buffer))
  78       (buffer-disable-undo)
  79       (erase-buffer))
  80     (when passphrase
  81       (setenv "PGPPASSFD" "0"))
  82     (unwind-protect
  83         (progn
  84           (let ((coding-system-for-read 'binary)
  85                 (coding-system-for-write 'binary))
  86             (setq process
  87                   (apply #'funcall
  88                          #'start-process-shell-command "*PGP*" output-buffer
  89                          program args)))
  90           (set-process-sentinel process #'ignore)
  91           (when passphrase
  92             (process-send-string process (concat passphrase "\n")))
  93           (process-send-region process start end)
  94           (process-send-eof process)
  95           (while (eq 'run (process-status process))
  96             (accept-process-output process 5))
  97           (setq status (process-status process)
  98                 exit-status (process-exit-status process))
  99           (delete-process process)
 100           (with-current-buffer output-buffer
 101             (pgg-convert-lbt-region (point-min)(point-max) 'LF)
 102
 103             (if (memq status '(stop signal))
 104                 (error "%s exited abnormally: '%s'" program exit-status))
 105             (if (= 127 exit-status)
 106                 (error "%s could not be found" program))
 107
 108             (set-buffer (get-buffer-create errors-buffer))
 109             (buffer-disable-undo)
 110             (erase-buffer)
 111             (insert-file-contents errors-file-name)))
 112       (if (and process (eq 'run (process-status process)))
 113           (interrupt-process process))
 114       (condition-case nil
 115           (delete-file errors-file-name)
 116         (file-error nil)))))
 117
 118 (defun pgg-pgp-lookup-key (string &optional type)
 119   "Search keys associated with STRING."
 120   (let ((args (list "+batchmode" "+language=en" "-kv" string)))
 121     (with-current-buffer (let ((default-enable-multibyte-characters t))
 122                            (get-buffer-create pgg-output-buffer))
 123       (buffer-disable-undo)
 124       (erase-buffer)
 125       (apply #'call-process pgg-pgp-program nil t nil args)
 126       (goto-char (point-min))
 127       (cond
 128        ((re-search-forward "^pub\\s +[0-9]+/" nil t);PGP 2.*
 129         (buffer-substring (point)(+ 8 (point))))
 130        ((re-search-forward "^Type" nil t);PGP 6.*
 131         (beginning-of-line 2)
 132         (substring
 133          (nth 2 (split-string
 134                  (buffer-substring (point)(progn (end-of-line) (point)))))
 135          2))))))
 136
 137 (defun pgg-pgp-encrypt-region (start end recipients &optional sign passphrase)
 138   "Encrypt the current region between START and END."
 139   (let* ((pgg-pgp-user-id (or pgg-pgp-user-id pgg-default-user-id))
 140          (passphrase (or passphrase
 141                          (when sign
 142                            (pgg-read-passphrase
 143                             (format "PGP passphrase for %s: "
 144                                     pgg-pgp-user-id)
 145                             pgg-pgp-user-id))))
 146          (args
 147           (append
 148            `("+encrypttoself=off +verbose=1" "+batchmode"
 149              "+language=us" "-fate"
 150              ,@(if recipients
 151                    (mapcar (lambda (rcpt) (concat "\"" rcpt "\""))
 152                            (append recipients
 153                                    (if pgg-encrypt-for-me
 154                                        (list pgg-pgp-user-id))))))
 155            (if sign '("-s" "-u" pgg-pgp-user-id)))))
 156     (pgg-pgp-process-region start end nil pgg-pgp-program args)
 157     (pgg-process-when-success nil)))
 158
 159 (defun pgg-pgp-decrypt-region (start end &optional passphrase)
 160   "Decrypt the current region between START and END.
 161
 162 If optional PASSPHRASE is not specified, it will be obtained from the
 163 passphrase cache or user."
 164   (let* ((pgg-pgp-user-id (or pgg-pgp-user-id pgg-default-user-id))
 165          (key (pgg-pgp-lookup-key pgg-pgp-user-id 'encrypt))
 166          (passphrase
 167           (or passphrase
 168               (pgg-read-passphrase
 169                (format "PGP passphrase for %s: " pgg-pgp-user-id) key)))
 170          (args
 171           '("+verbose=1" "+batchmode" "+language=us" "-f")))
 172     (pgg-pgp-process-region start end passphrase pgg-pgp-program args)
 173     (pgg-process-when-success
 174       (if pgg-cache-passphrase
 175           (pgg-add-passphrase-to-cache key passphrase)))))
 176
 177 (defun pgg-pgp-sign-region (start end &optional clearsign passphrase)
 178   "Make detached signature from text between START and END.
 179
 180 If optional PASSPHRASE is not specified, it will be obtained from the
 181 passphrase cache or user."
 182   (let* ((pgg-pgp-user-id (or pgg-pgp-user-id pgg-default-user-id))
 183          (passphrase
 184           (or passphrase
 185               (pgg-read-passphrase
 186                (format "PGP passphrase for %s: " pgg-pgp-user-id)
 187                (pgg-pgp-lookup-key pgg-pgp-user-id 'sign))))
 188          (args
 189           (list (if clearsign "-fast" "-fbast")
 190                 "+verbose=1" "+language=us" "+batchmode"
 191                 "-u" pgg-pgp-user-id)))
 192     (pgg-pgp-process-region start end passphrase pgg-pgp-program args)
 193     (pgg-process-when-success
 194       (goto-char (point-min))
 195       (when (re-search-forward "^-+BEGIN PGP" nil t);XXX
 196         (let ((packet
 197                (cdr (assq 2 (pgg-parse-armor-region
 198                              (progn (beginning-of-line 2)
 199                                     (point))
 200                              (point-max))))))
 201           (if pgg-cache-passphrase
 202               (pgg-add-passphrase-to-cache
 203                (cdr (assq 'key-identifier packet))
 204                passphrase)))))))
 205
 206 (defun pgg-pgp-verify-region (start end &optional signature)
 207   "Verify region between START and END as the detached signature SIGNATURE."
 208   (let* ((orig-file (pgg-make-temp-file "pgg"))
 209          (args '("+verbose=1" "+batchmode" "+language=us"))
 210          (orig-mode (default-file-modes)))
 211     (unwind-protect
 212         (progn
 213           (set-default-file-modes 448)
 214           (let ((coding-system-for-write 'binary)
 215                 jka-compr-compression-info-list jam-zcat-filename-list)
 216             (write-region start end orig-file)))
 217       (set-default-file-modes orig-mode))
 218     (if (stringp signature)
 219         (progn
 220           (copy-file signature (setq signature (concat orig-file ".asc")))
 221           (setq args (append args (list signature orig-file))))
 222       (setq args (append args (list orig-file))))
 223     (pgg-pgp-process-region (point)(point) nil pgg-pgp-program args)
 224     (delete-file orig-file)
 225     (if signature (delete-file signature))
 226     (pgg-process-when-success
 227       (goto-char (point-min))
 228       (let ((case-fold-search t))
 229         (while (re-search-forward "^warning: " nil t)
 230           (delete-region (match-beginning 0)
 231                          (progn (beginning-of-line 2) (point)))))
 232       (goto-char (point-min))
 233       (when (re-search-forward "^\\.$" nil t)
 234         (delete-region (point-min)
 235                        (progn (beginning-of-line 2)
 236                               (point)))))))
 237
 238 (defun pgg-pgp-insert-key ()
 239   "Insert public key at point."
 240   (let* ((pgg-pgp-user-id (or pgg-pgp-user-id pgg-default-user-id))
 241          (args
 242           (list "+verbose=1" "+batchmode" "+language=us" "-kxaf"
 243                 (concat "\"" pgg-pgp-user-id "\""))))
 244     (pgg-pgp-process-region (point)(point) nil pgg-pgp-program args)
 245     (insert-buffer-substring pgg-output-buffer)))
 246
 247 (defun pgg-pgp-snarf-keys-region (start end)
 248   "Add all public keys in region between START and END to the keyring."
 249   (let* ((pgg-pgp-user-id (or pgg-pgp-user-id pgg-default-user-id))
 250          (key-file (pgg-make-temp-file "pgg"))
 251          (args
 252           (list "+verbose=1" "+batchmode" "+language=us" "-kaf"
 253                 key-file)))
 254     (let ((coding-system-for-write 'raw-text-dos))
 255       (write-region start end key-file))
 256     (pgg-pgp-process-region start end nil pgg-pgp-program args)
 257     (delete-file key-file)
 258     (pgg-process-when-success nil)))
 259
 260 (provide 'pgg-pgp)
 261
 262 ;;; arch-tag: 076b7801-37b2-49a6-97c3-218fdecde33c
 263 ;;; pgg-pgp.el ends here