pgg.el

   1 ;;; pgg.el --- glue for the various PGP implementations.
   2
   3 ;; Copyright (C) 1999 Daiki Ueno
   4
   5 ;; Author: Daiki Ueno <ueno@ueda.info.waseda.ac.jp>
   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 ;;; Code:
  27
  28 (require 'calist)
  29
  30 (eval-and-compile (require 'luna))
  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 (in-calist-package 'pgg)
  41
  42 (defun pgg-field-match-method-with-containment
  43   (calist field-type field-value)
  44   (let ((s-field (assq field-type calist)))
  45     (cond ((null s-field)
  46            (cons (cons field-type field-value) calist)
  47            )
  48           ((memq (cdr s-field) field-value)
  49            calist))))
  50
  51 (define-calist-field-match-method 'signature-version
  52   #'pgg-field-match-method-with-containment)
  53
  54 (define-calist-field-match-method 'cipher-algorithm
  55   #'pgg-field-match-method-with-containment)
  56
  57 (define-calist-field-match-method 'public-key-algorithm
  58   #'pgg-field-match-method-with-containment)
  59
  60 (define-calist-field-match-method 'hash-algorithm
  61   #'pgg-field-match-method-with-containment)
  62
  63 (defvar pgg-verify-codition nil
  64   "Condition-tree about how to display entity.")
  65
  66 (defvar pgg-decrypt-codition nil
  67   "Condition-tree about how to display entity.")
  68
  69 (ctree-set-calist-strictly
  70  'pgg-verify-codition
  71  '((signature-version 3)(public-key-algorithm RSA)(hash-algorithm MD5)
  72    (scheme . pgp)))
  73
  74 (ctree-set-calist-strictly
  75  'pgg-decrypt-codition
  76  '((public-key-algorithm RSA)(symmetric-key-algorithm IDEA)
  77    (scheme . pgp)))
  78
  79 (ctree-set-calist-strictly
  80  'pgg-verify-codition
  81  '((signature-version 3 4)
  82    (public-key-algorithm RSA ELG DSA)
  83    (hash-algorithm MD5 SHA1 RIPEMD160)
  84    (scheme . pgp5)))
  85
  86 (ctree-set-calist-strictly
  87  'pgg-decrypt-codition
  88  '((public-key-algorithm RSA ELG DSA)
  89    (symmetric-key-algorithm 3DES CAST5 IDEA)
  90    (scheme . pgp5)))
  91
  92 (ctree-set-calist-strictly
  93  'pgg-verify-codition
  94  '((signature-version 3 4)
  95    (public-key-algorithm ELG-E DSA ELG)
  96    (hash-algorithm MD5 SHA1 RIPEMD160)
  97    (scheme . gpg)))
  98
  99 (ctree-set-calist-strictly
 100  'pgg-decrypt-codition
 101  '((public-key-algorithm ELG-E DSA ELG)
 102    (symmetric-key-algorithm 3DES CAST5 BLOWFISH TWOFISH)
 103    (scheme . gpg)))
 104
 105 ;;; @ definition of the implementation scheme
 106 ;;;
 107
 108 (eval-and-compile
 109   (luna-define-class pgg-scheme ())
 110
 111   (luna-define-internal-accessors 'pgg-scheme)
 112   )
 113
 114 (luna-define-generic lookup-key-string (scheme string &optional type)
 115   "Search keys associated with STRING")
 116
 117 (luna-define-generic encrypt-region (scheme start end recipients)
 118   "Encrypt the current region between START and END.")
 119
 120 (luna-define-generic decrypt-region (scheme start end)
 121   "Decrypt the current region between START and END.")
 122
 123 (luna-define-generic sign-region (scheme start end)
 124   "Make detached signature from text between START and END.")
 125
 126 (luna-define-generic verify-region (scheme start end &optional signature)
 127   "Verify region between START and END
 128 as the detached signature SIGNATURE.")
 129
 130 (luna-define-generic insert-key (scheme)
 131   "Insert public key at point.")
 132
 133 (luna-define-generic snarf-keys-region (scheme start end)
 134   "Add all public keys in region between START
 135 and END to the keyring.")
 136
 137 ;;; @ interface functions
 138 ;;;
 139
 140 (defmacro pgg-make-scheme (scheme)
 141   `(progn
 142      (require (intern (format "pgg-%s" ,scheme)))
 143      (funcall (intern (format "pgg-make-scheme-%s"
 144                               ,scheme)))))
 145
 146 (defun pgg-encrypt-region (start end rcpts)
 147   (interactive
 148    (list (region-beginning)(region-end)
 149          (split-string (read-string "Recipients: ") "[ \t,]+")))
 150   (let ((entity (pgg-make-scheme pgg-default-scheme)))
 151     (luna-send entity 'encrypt-region entity start end rcpts)))
 152
 153 (defun pgg-decrypt-region (start end)
 154   (interactive "r")
 155   (let* ((packet (cdr (assq 1 (pgg-parse-armor-region start end))))
 156          (scheme
 157           (or pgg-scheme
 158               (cdr (assq 'scheme
 159                          (progn
 160                            (in-calist-package 'pgg)
 161                            (ctree-match-calist pgg-decrypt-codition
 162                                                packet))))
 163               pgg-default-scheme))
 164          (entity (pgg-make-scheme scheme)))
 165     (luna-send entity 'decrypt-region entity start end)))
 166
 167 (defun pgg-sign-region (start end)
 168   (interactive "r")
 169   (let ((entity (pgg-make-scheme pgg-default-scheme)))
 170     (luna-send entity 'sign-region entity start end)))
 171
 172 (defun pgg-verify-region (start end &optional signature fetch)
 173   (interactive "r")
 174   (let* ((packet
 175           (with-temp-buffer
 176             (buffer-disable-undo)
 177             (set-buffer-multibyte nil)
 178             (insert-file-contents signature)
 179             (cdr (assq 2 (pgg-decode-armor-region (point-min)(point-max))))
 180             ))
 181          (scheme
 182           (or pgg-scheme
 183               (cdr (assq 'scheme
 184                          (progn
 185                            (in-calist-package 'pgg)
 186                            (ctree-match-calist pgg-verify-codition
 187                                                packet))))
 188               pgg-default-scheme))
 189          (entity (pgg-make-scheme scheme))
 190          (key (cdr (assq 'key-identifier packet)))
 191          keyserver)
 192     (and (stringp key)
 193          (setq key (concat "0x" (pgg-truncate-key-identifier key)))
 194          (null (pgg-lookup-key-string key))
 195          fetch
 196          (y-or-n-p (format "Key %s not found; attempt to fetch? " key))
 197          (setq keyserver
 198                (or (cdr (assq 'preferred-key-server packet))
 199                    pgg-default-keyserver-address))
 200          (ignore-errors (require 'url))
 201          (pgg-fetch-key
 202           (if (url-type (url-generic-parse-url keyserver))
 203               keyserver
 204             (format "http://%s:11371/pks/lookup?op=get&search=%s"
 205                     keyserver key))))
 206     (luna-send entity 'verify-region entity start end signature)))
 207
 208 (defun pgg-insert-key ()
 209   (let ((entity (pgg-make-scheme (or pgg-scheme pgg-default-scheme))))
 210     (luna-send entity 'insert-key entity)))
 211
 212 (defun pgg-snarf-keys-region (start end)
 213   (let ((entity (pgg-make-scheme (or pgg-scheme pgg-default-scheme))))
 214     (luna-send entity 'snarf-keys-region entity start end)))
 215
 216 (defun pgg-lookup-key-string (string &optional type)
 217   (let ((entity (pgg-make-scheme (or pgg-scheme pgg-default-scheme))))
 218     (luna-send entity 'lookup-key-string entity string type)))
 219
 220 (defun pgg-fetch-key (url)
 221   "Attempt to fetch a key for addition to PGP or GnuPG keyring.
 222
 223 Return t if we think we were successful; nil otherwise.  Note that nil
 224 is not necessarily an error, since we may have merely fired off an Email
 225 request for the key."
 226   (require 'w3)
 227   (require 'url)
 228   (with-current-buffer (get-buffer-create pgg-output-buffer)
 229     (buffer-disable-undo)
 230     (erase-buffer)
 231     (let ((proto (url-type (url-generic-parse-url url)))
 232           buffer-file-name)
 233       (unless (memq (intern proto) '(http finger))
 234         (insert (format "Protocol %s is not supported.\n" proto)))
 235       (url-insert-file-contents url)
 236       (if (re-search-forward "^-+BEGIN" nil 'last)
 237           (progn
 238             (delete-region (point-min) (match-beginning 0))
 239             (when (re-search-forward "^-+END" nil t)
 240               (delete-region (progn (end-of-line) (point))
 241                              (point-max)))
 242             (insert "\n")
 243             (with-temp-buffer
 244               (insert-buffer-substring pgg-output-buffer)
 245               (pgg-snarf-keys-region (point-min)(point-max))))
 246         (erase-buffer)
 247         (insert "Cannot retrieve public key from URL (" url ")\n")))
 248     ))
 249
 250
 251 ;;; @ utility functions
 252 ;;;
 253
 254 (defvar pgg-passphrase-cache-expiry 16)
 255 (defvar pgg-passphrase-cache (make-vector 7 0))
 256
 257 (defvar pgg-read-passphrase nil)
 258 (defun pgg-read-passphrase (prompt &optional key)
 259   (if (not pgg-read-passphrase)
 260       (if (functionp 'read-passwd)
 261           (setq pgg-read-passphrase 'read-passwd)
 262         (if (load "passwd" t)
 263             (setq pgg-read-passphrase 'read-passwd)
 264           (autoload 'ange-ftp-read-passwd "ange-ftp")
 265           (setq pgg-read-passphrase 'ange-ftp-read-passwd))))
 266   (or (and key (setq key (pgg-truncate-key-identifier key))
 267            (symbol-value (intern-soft key pgg-passphrase-cache)))
 268       (funcall pgg-read-passphrase prompt)))
 269
 270 (defun pgg-add-passphrase-cache (key passphrase)
 271   (setq key (pgg-truncate-key-identifier key))
 272   (set (intern key pgg-passphrase-cache)
 273        passphrase)
 274   (run-at-time pgg-passphrase-cache-expiry nil
 275                #'pgg-remove-passphrase-cache
 276                key))
 277
 278 (defun pgg-remove-passphrase-cache (key)
 279   (unintern key pgg-passphrase-cache))
 280
 281 (provide 'pgg)
 282
 283 ;;; pgg.el ends here