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 (in-calist-package 'pgg)
  36
  37 (defun pgg-field-match-method-with-containment
  38   (calist field-type field-value)
  39   (let ((s-field (assq field-type calist)))
  40     (cond ((null s-field)
  41            (cons (cons field-type field-value) calist)
  42            )
  43           ((memq (cdr s-field) field-value)
  44            calist))))
  45
  46 (define-calist-field-match-method 'signature-version
  47   #'pgg-field-match-method-with-containment)
  48
  49 (define-calist-field-match-method 'cipher-algorithm
  50   #'pgg-field-match-method-with-containment)
  51
  52 (define-calist-field-match-method 'public-key-algorithm
  53   #'pgg-field-match-method-with-containment)
  54
  55 (define-calist-field-match-method 'hash-algorithm
  56   #'pgg-field-match-method-with-containment)
  57
  58 (defvar pgg-verify-codition nil
  59   "Condition-tree about how to display entity.")
  60
  61 (defvar pgg-decrypt-codition nil
  62   "Condition-tree about how to display entity.")
  63
  64 (ctree-set-calist-strictly
  65  'pgg-verify-codition
  66  '((signature-version 3)(public-key-algorithm RSA)(hash-algorithm MD5)
  67    (scheme . pgp)))
  68
  69 (ctree-set-calist-strictly
  70  'pgg-decrypt-codition
  71  '((cipher-algorithm IDEA)(public-key-algorithm RSA)
  72    (scheme . pgp)))
  73
  74 (ctree-set-calist-strictly
  75  'pgg-verify-codition
  76  '((signature-version 3 4)
  77    (public-key-algorithm RSA ELG DSA)
  78    (hash-algorithm MD5 SHA1 RIPEMD160)
  79    (scheme . pgp5)))
  80
  81 (ctree-set-calist-strictly
  82  'pgg-decrypt-codition
  83  '((cipher-algorithm 3DES CAST5 IDEA)
  84    (public-key-algorithm RSA ELG DSA)
  85    (scheme . pgp5)))
  86
  87 (ctree-set-calist-strictly
  88  'pgg-verify-codition
  89  '((signature-version 3 4)
  90    (public-key-algorithm ELG-E DSA ELG)
  91    (hash-algorithm MD5 SHA1 RIPEMD160)
  92    (scheme . gpg)))
  93
  94 (ctree-set-calist-strictly
  95  'pgg-decrypt-codition
  96  '((public-key-algorithm ELG-E DSA ELG)
  97    (cipher-algorithm 3DES CAST5 BLOWFISH TWOFISH)
  98    (scheme . gpg)))
  99
 100 ;;; @ definition of the implementation scheme
 101 ;;;
 102
 103 (eval-and-compile
 104   (luna-define-class pgg-scheme ()
 105                      (message-beginning-line
 106                       message-end-line
 107                       signed-beginning-line
 108                       signed-end-line
 109                       key-beginning-line
 110                       key-end-line
 111                       ))
 112
 113   (luna-define-internal-accessors 'pgg-scheme)
 114   )
 115
 116 (luna-define-generic encrypt-region (scheme start end recipients)
 117   "Encrypt the current region between START and END.")
 118
 119 (luna-define-generic decrypt-region (scheme start end)
 120   "Decrypt the current region between START and END.")
 121
 122 (luna-define-generic sign-region (scheme start end)
 123   "Make detached signature from text between START and END.")
 124
 125 (luna-define-generic verify-region (scheme start end &optional signature)
 126   "Verify region between START and END
 127 as the detached signature SIGNATURE.")
 128
 129 (luna-define-generic insert-key (scheme)
 130   "Insert public key at point.")
 131
 132 (luna-define-generic snarf-keys-region (scheme start end)
 133   "Add all public keys in region between START
 134 and END to the keyring.")
 135
 136 (defvar pgg-scheme-message-delimiters
 137   '(:message-beginning-line
 138     "^-----BEGIN PGP MESSAGE-----\r?$"
 139     :message-end-line
 140     "^-----END PGP MESSAGE-----\r?$"
 141     :signed-beginning-line
 142     "^-----BEGIN PGP SIGNED MESSAGE-----\r?$"
 143     :signed-end-line
 144     "^-----END PGP SIGNATURE-----\r?$"
 145     :key-beginning-line
 146     "^-----BEGIN PGP PUBLIC KEY BLOCK-----\r?$"
 147     :key-end-line
 148     "^-----END PGP PUBLIC KEY BLOCK-----\r?$")
 149   "Message delimiters")
 150
 151 (luna-define-method initialize-instance :before ((scheme pgg-scheme)
 152                                                  &rest init-args)
 153   (let ((luna-current-method-arguments
 154          (cons scheme (or init-args
 155                           pgg-scheme-message-delimiters))))
 156     (luna-call-next-method)))
 157
 158 ;;; @ interface functions
 159 ;;;
 160
 161 (defmacro pgg-make-scheme (scheme)
 162   `(progn
 163      (require (intern (format "pgg-%s" ,scheme)))
 164      (funcall (intern (format "pgg-make-scheme-%s"
 165                               ,scheme)))))
 166
 167 (defun pgg-encrypt-region (start end rcpts)
 168   (let ((entity (pgg-make-scheme pgg-default-scheme)))
 169     (luna-send entity 'encrypt-region entity start end rcpts)))
 170
 171 (defun pgg-decrypt-region (start end)
 172   (let* ((packets (pgg-parse-armor-region start end))
 173          (scheme
 174           (or pgg-scheme
 175               (cdr (assq 'scheme
 176                          (progn
 177                            (in-calist-package 'pgg)
 178                            (ctree-match-calist pgg-decrypt-codition
 179                                                packets))))
 180               pgg-default-scheme))
 181          (entity (pgg-make-scheme scheme)))
 182     (luna-send entity 'decrypt-region entity start end)))
 183
 184 (defun pgg-sign-region (start end)
 185   (let ((entity (pgg-make-scheme pgg-default-scheme)))
 186     (luna-send entity 'sign-region entity start end)))
 187
 188 (defun pgg-verify-region (start end &optional signature)
 189   (let* ((packets
 190           (with-temp-buffer
 191             (buffer-disable-undo)
 192             (set-buffer-multibyte nil)
 193             (insert-file-contents signature)
 194             (pgg-decode-armor-region (point-min)(point-max))
 195             ))
 196          (scheme
 197           (or pgg-scheme
 198               (cdr (assq 'scheme
 199                          (progn
 200                            (in-calist-package 'pgg)
 201                            (ctree-match-calist pgg-verify-codition
 202                                                packets))))
 203               pgg-default-scheme))
 204          (entity (pgg-make-scheme scheme)))
 205     (luna-send entity 'verify-region entity start end signature)))
 206
 207 (defun pgg-insert-key ()
 208   (let ((entity (pgg-make-scheme pgg-default-scheme)))
 209     (luna-send entity 'insert-key entity)))
 210
 211 (defun pgg-snarf-keys-region (start end)
 212   (let ((entity (pgg-make-scheme pgg-default-scheme)))
 213     (luna-send entity 'snarf-keys-region start end)))
 214
 215 ;;; @ utility functions
 216 ;;;
 217
 218 (defvar pgg-passphrase-cache-expiry 16)
 219 (defvar pgg-passphrase-cache (make-vector 7 0))
 220
 221 (defvar pgg-read-passphrase nil)
 222 (defun pgg-read-passphrase (prompt &optional key)
 223   (if (not pgg-read-passphrase)
 224       (if (functionp 'read-passwd)
 225           (setq pgg-read-passphrase 'read-passwd)
 226         (if (load "passwd" t)
 227             (setq pgg-read-passphrase 'read-passwd)
 228           (autoload 'ange-ftp-read-passwd "ange-ftp")
 229           (setq pgg-read-passphrase 'ange-ftp-read-passwd))))
 230   (or (and key (symbol-value (intern-soft key pgg-passphrase-cache)))
 231       (funcall pgg-read-passphrase prompt)))
 232
 233 (defun pgg-add-passphrase-cache (key passphrase)
 234   (set (intern key pgg-passphrase-cache)
 235        passphrase)
 236   (run-at-time pgg-passphrase-cache-expiry nil
 237                #'pgg-remove-passphrase-cache
 238                key))
 239
 240 (defun pgg-remove-passphrase-cache (key)
 241   (unintern key pgg-passphrase-cache))
 242
 243 (provide 'pgg)
 244
 245 ;;; pgg.el ends here