cgit.sxemacs.org Git - packages/blob - xemacs-packages/mailcrypt/mc-pgp.el

   1 ;; mc-pgp.el, PGP support for Mailcrypt
   2 ;; Copyright (C) 1995  Jin Choi <jin@atype.com>
   3 ;;                     Patrick LoPresti <patl@lcs.mit.edu>
   4
   5 ;;{{{ Licensing
   6 ;; This file is intended to be used with GNU Emacs.
   7
   8 ;; This program is free software; you can redistribute it and/or modify
   9 ;; it under the terms of the GNU General Public License as published by
  10 ;; the Free Software Foundation; either version 2, or (at your option)
  11 ;; any later version.
  12
  13 ;; This program is distributed in the hope that it will be useful,
  14 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  15 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  16 ;; GNU General Public License for more details.
  17
  18 ;; You should have received a copy of the GNU General Public License
  19 ;; along with GNU Emacs; see the file COPYING.  If not, write to
  20 ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  21 ;;}}}
  22 (require 'mailcrypt)
  23
  24 (defvar mc-pgp-user-id (user-login-name)
  25   "*PGP ID of your default identity.")
  26 (defvar mc-pgp-path "pgp" "*The PGP executable.")
  27 (defvar mc-pgp-display-snarf-output nil
  28   "*If t, pop up the PGP output window when snarfing keys.")
  29 (defvar mc-pgp-always-fetch nil
  30   "*If t, always fetch missing keys. If nil, prompt user. If 'never,
  31 never fetch keys, and don't ask.")
  32 (defvar mc-pgp-alternate-keyring nil
  33   "*Public keyring to use instead of default.")
  34 (defvar mc-pgp-comment
  35   (format "Processed by Mailcrypt %s, an Emacs/PGP interface" mc-version)
  36   "*Comment field to appear in ASCII armor output.  If nil, let PGP
  37 use its default.")
  38
  39 (defconst mc-pgp-msg-begin-line "^-----BEGIN PGP MESSAGE-----\r?$"
  40   "Text for start of PGP message delimiter.")
  41 (defconst mc-pgp-msg-end-line "^-----END PGP MESSAGE-----\r?$"
  42   "Text for end of PGP message delimiter.")
  43 (defconst mc-pgp-signed-begin-line "^-----BEGIN PGP SIGNED MESSAGE-----\r?$"
  44   "Text for start of PGP signed messages.")
  45 (defconst mc-pgp-signed-end-line "^-----END PGP SIGNATURE-----\r?$"
  46   "Text for end of PGP signed messages.")
  47 (defconst mc-pgp-key-begin-line "^-----BEGIN PGP PUBLIC KEY BLOCK-----\r?$"
  48   "Text for start of PGP public key.")
  49 (defconst mc-pgp-key-end-line "^-----END PGP PUBLIC KEY BLOCK-----\r?$"
  50   "Text for end of PGP public key.")
  51 (defconst mc-pgp-error-re "^\\(ERROR:\\|WARNING:\\).*"
  52   "Regular expression matching an error from PGP")
  53 (defconst mc-pgp-sigok-re "^.*Good signature.*"
  54   "Regular expression matching a PGP signature validation message")
  55 (defconst mc-pgp-newkey-re "^[ \t]*\\(No\\|[0-9]+\\) +new [ku].*"
  56   "Regular expression matching a PGP key snarf message")
  57 (defconst mc-pgp-nokey-re
  58   "Cannot find the public key matching userid '\\(.+\\)'$"
  59   "Regular expression matching a PGP missing-key messsage")
  60 (defconst mc-pgp-key-expected-re
  61   "Key matching expected Key ID \\(\\S +\\) not found")
  62
  63 (defvar mc-pgp-keydir nil
  64   "Directory in which keyrings are stored.")
  65
  66 (defun mc-get-pgp-keydir ()
  67   (if (null mc-pgp-keydir)
  68       (let ((buffer (generate-new-buffer " *mailcrypt temp*"))
  69             (obuf (current-buffer)))
  70         (unwind-protect
  71             (progn
  72               (call-process mc-pgp-path nil buffer nil "+verbose=1"
  73                             "+language=en" "-kv" "XXXXXXXXXX")
  74               (set-buffer buffer)
  75               (goto-char (point-min))
  76               (re-search-forward "^Key ring:\\s *'\\(.*\\)'")
  77               (setq mc-pgp-keydir
  78                     (file-name-directory
  79                      (buffer-substring-no-properties
  80                       (match-beginning 1) (match-end 1)))))
  81           (set-buffer obuf)
  82           (kill-buffer buffer))))
  83   mc-pgp-keydir)
  84
  85 (defvar mc-pgp-key-cache nil
  86   "Association list mapping PGP IDs to canonical \"keys\".  A \"key\"
  87 is a pair (USER-ID . KEY-ID) which identifies the canonical IDs of the
  88 PGP ID.")
  89
  90 (defun mc-pgp-lookup-key (str)
  91   ;; Look up the string STR in the user's secret key ring.  Return a
  92   ;; pair of strings (USER-ID . KEY-ID) which uniquely identifies the
  93   ;; matching key, or nil if no key matches.
  94   (if (equal str "***** CONVENTIONAL *****") nil
  95     (let ((keyring (concat (mc-get-pgp-keydir) "secring"))
  96           (result (cdr-safe (assoc str mc-pgp-key-cache)))
  97           (key-regexp
  98            "^\\(\\(pub\\|sec\\)\\s +[^/]+/\\(\\S *\\)\\s +\\S +\\s +\\(.*\\)\\)$")
  99           (revoke-regexp "REVOKED")
 100           (obuf (current-buffer))
 101           buffer key-start key-end)
 102       (if (null result)
 103           (unwind-protect
 104               (progn
 105                 (setq buffer (generate-new-buffer " *mailcrypt temp"))
 106                 (call-process mc-pgp-path nil buffer nil
 107                               "+language=en" "-kv" str keyring)
 108                 (set-buffer buffer)
 109                 (goto-char (point-min))
 110                 (while (and (null result)
 111                             (re-search-forward key-regexp nil t))
 112                     (progn
 113                       (setq result
 114                             (cons (buffer-substring-no-properties
 115                                    (match-beginning 4) (match-end 4))
 116                                   (concat
 117                                    "0x"
 118                                    (buffer-substring-no-properties
 119                                     (match-beginning 3) (match-end 3)))))
 120                       (setq key-start (match-beginning 1))
 121                       (setq key-end (match-end 1))
 122                       (save-restriction
 123                             (narrow-to-region key-start key-end)
 124                             (goto-char (point-min))
 125                             (if (re-search-forward revoke-regexp nil t)
 126                                 (setq result nil)
 127                               (setq mc-pgp-key-cache
 128                                     (cons (cons str result)
 129                                           mc-pgp-key-cache)))))))
 130             (if buffer (kill-buffer buffer))
 131             (set-buffer obuf)))
 132       (if (null result) nil )             ; We don't mind a missing "secring"
 133       result)))
 134
 135 (defun mc-pgp-generic-parser (result)
 136   (let (start)
 137     (goto-char (point-min))
 138     (cond ((not (eq result 0))
 139            (prog1
 140                nil
 141              (if (mc-message "^\aError: +Bad pass phrase\\.$" (current-buffer))
 142                  (mc-deactivate-passwd t)
 143                (mc-message mc-pgp-error-re (current-buffer)
 144                            (format "PGP exited with status %d" result)))))
 145           ((re-search-forward mc-pgp-nokey-re nil t)
 146            nil)
 147           (t
 148            (and
 149             (goto-char (point-min))
 150             (re-search-forward "-----BEGIN PGP.*-----$" nil t)
 151             (setq start (match-beginning 0))
 152             (goto-char (point-max))
 153             (re-search-backward "^-----END PGP.*-----\n" nil t)
 154             (cons start (match-end 0)))))))
 155
 156 (defun mc-pgp-encrypt-region (recipients start end &optional id sign)
 157   (let ((process-environment process-environment)
 158         (buffer (get-buffer-create mc-buffer-name))
 159         ;; Crock.  Rewrite someday.
 160         (mc-pgp-always-sign mc-pgp-always-sign)
 161         (obuf (current-buffer))
 162         action msg args key passwd result pgp-id)
 163     (setq args (list "+encrypttoself=off +verbose=1" "+batchmode"
 164                      "+language=en" "-fat"))
 165     (setq action (if recipients "Encrypting" "Armoring"))
 166     (setq msg (format "%s..." action))  ; May get overridden below
 167     (if recipients (setq args (cons "-e" args)))
 168     (if mc-pgp-comment
 169         (setq args (cons (format "+comment=%s" mc-pgp-comment) args)))
 170     (if mc-pgp-alternate-keyring
 171         (setq args (append args (list (format "+pubring=%s"
 172                                               mc-pgp-alternate-keyring)))))
 173     (if (and (not (eq mc-pgp-always-sign 'never))
 174              (or mc-pgp-always-sign sign (y-or-n-p "Sign the message? ")))
 175         (progn
 176           (setq mc-pgp-always-sign t)
 177           (setq key (mc-pgp-lookup-key (or id mc-pgp-user-id)))
 178           (if (not key) (error "No key available for signing."))
 179           (setq passwd
 180                 (mc-activate-passwd
 181                  (cdr key)
 182                  (format "PGP passphrase for %s (%s): " (car key) (cdr key))))
 183           (setq args
 184                 (nconc args (list "-s" "-u" (cdr key))))
 185           (setenv "PGPPASSFD" "0")
 186           (setq msg (format "%s+signing as %s ..." action (car key))))
 187       (setq mc-pgp-always-sign 'never))
 188
 189     (or key
 190         (setq key (mc-pgp-lookup-key mc-pgp-user-id)))
 191
 192     (if (and recipients mc-encrypt-for-me)
 193         (setq recipients (cons (cdr key) recipients)))
 194
 195     (setq args (append args recipients))
 196
 197     (message "%s" msg)
 198     (setq result (mc-process-region start end passwd mc-pgp-path args
 199                                     'mc-pgp-generic-parser buffer))
 200     (save-excursion
 201       (set-buffer buffer)
 202       (goto-char (point-min))
 203       (if (re-search-forward mc-pgp-nokey-re nil t)
 204           (progn
 205             (if result (error "This should never happen."))
 206             (setq pgp-id (buffer-substring-no-properties
 207                           (match-beginning 1) (match-end 1)))
 208             (if (and (not (eq mc-pgp-always-fetch 'never))
 209                      (or mc-pgp-always-fetch
 210                          (y-or-n-p
 211                           (format "Key for '%s' not found; try to fetch? "
 212                                   pgp-id))))
 213                 (progn
 214                   (mc-pgp-fetch-key (cons pgp-id nil))
 215                   (set-buffer obuf)
 216                   (mc-pgp-encrypt-region recipients start end id))
 217               (mc-message mc-pgp-nokey-re buffer)
 218               nil))
 219         (if (not result)
 220             nil
 221           (message "%s Done." msg)
 222           t)))))
 223
 224 (defun mc-pgp-decrypt-parser (result)
 225   (goto-char (point-min))
 226   (cond ((eq result 0)
 227          ;; Valid signature
 228          (re-search-forward "^Signature made.*\n")
 229          (if (looking-at
 230               "\a\nWARNING:  Because this public key.*\n.*\n.*\n")
 231              (goto-char (match-end 0)))
 232          (cons (point) (point-max)))
 233         ((eq result 1)
 234          (re-search-forward
 235           "\\(\\(^File is conven.*\\)?Just a moment\\.+\\)\\|\\(^\\.\\)")
 236          (if (eq (match-beginning 2) (match-end 2))
 237              (if (looking-at
 238                   "\nFile has signature.*\\(\n\a.*\n\\)*\nWARNING:.*\n")
 239                  (goto-char (match-end 0)))
 240            (if (looking-at "Pass phrase appears good\\. \\.")
 241                (goto-char (match-end 0))))
 242          (cons (point) (point-max)))
 243         (t nil)))
 244
 245 (defun mc-pgp-decrypt-region (start end &optional id)
 246   ;; returns a pair (SUCCEEDED . VERIFIED) where SUCCEEDED is t if
 247   ;; the decryption succeeded and verified is t if there was a valid signature
 248   (let ((process-environment process-environment)
 249         (buffer (get-buffer-create mc-buffer-name))
 250         args key new-key passwd result pgp-id)
 251     (undo-boundary)
 252     (setq key (mc-pgp-lookup-key (or id mc-pgp-user-id)))
 253 ;    (if (not key) (error "No key available for decrypting."))
 254     (setq
 255      passwd
 256      (if key
 257          (mc-activate-passwd (cdr key)
 258                              (and id
 259                                   (format "PGP passphrase for %s (%s): "
 260                                           (car key) (cdr key))))
 261        (mc-activate-passwd id "PGP passphrase for conventional decryption: ")))
 262     (if passwd
 263         (setenv "PGPPASSFD" "0"))
 264     (setq args '("+verbose=1" "+batchmode" "+language=en" "-f"))
 265     (if mc-pgp-alternate-keyring
 266         (setq args (append args (list (format "+pubring=%s"
 267                                               mc-pgp-alternate-keyring)))))
 268     (message "Decrypting...")
 269     (setq result
 270           (mc-process-region
 271            start end passwd mc-pgp-path args 'mc-pgp-decrypt-parser buffer))
 272     (cond
 273      (result
 274       (message "Decrypting... Done.")
 275       ;; If verification failed due to missing key, offer to fetch it.
 276       (save-excursion
 277         (set-buffer buffer)
 278         (goto-char (point-min))
 279         (if (re-search-forward mc-pgp-key-expected-re nil t)
 280             (setq pgp-id (concat "0x" (buffer-substring-no-properties
 281                                        (match-beginning 1)
 282                                        (match-end 1))))))
 283       (if (and pgp-id
 284                (not (eq mc-pgp-always-fetch 'never))
 285                (or mc-pgp-always-fetch
 286                    (y-or-n-p
 287                     (format "Key %s not found; attempt to fetch? " pgp-id)))
 288                (mc-pgp-fetch-key (cons nil pgp-id)))
 289           (progn
 290             (undo-start)
 291             (undo-more 1)
 292             (mc-pgp-decrypt-region start end id))
 293         (mc-message mc-pgp-key-expected-re buffer)
 294         (cons t (eq result 0))))
 295      ;; Decryption failed; maybe we need to use a different user-id
 296      ((save-excursion
 297         (and
 298          (set-buffer buffer)
 299          (goto-char (point-min))
 300          (re-search-forward
 301           "^Key for user ID:.*\n.*Key ID \\([0-9A-F]+\\)" nil t)
 302          (setq new-key
 303                (mc-pgp-lookup-key
 304                 (concat "0x" (buffer-substring-no-properties
 305                               (match-beginning 1)
 306                               (match-end 1)))))
 307          (not (and id (equal key new-key)))))
 308       (mc-pgp-decrypt-region start end (cdr new-key)))
 309      ;; Or maybe it is conventionally encrypted
 310      ((save-excursion
 311         (and
 312          (set-buffer buffer)
 313          (goto-char (point-min))
 314          (re-search-forward "^File is conventionally encrypted" nil t)))
 315       (if (null key) (mc-deactivate-passwd t))
 316       (mc-pgp-decrypt-region start end "***** CONVENTIONAL *****"))
 317      ;; Or maybe this is the wrong PGP version
 318      ((save-excursion
 319         (and
 320          (set-buffer buffer)
 321          (goto-char (point-min))
 322          (re-search-forward "Unsupported packet format" nil t)))
 323       (mc-message mc-pgp-error-re buffer "Not encrypted for PGP 2.6"))
 324      (t
 325       (mc-display-buffer buffer)
 326       (if (mc-message "^\aError: +Bad pass phrase\\.$" buffer)
 327           (mc-deactivate-passwd t)
 328         (mc-message mc-pgp-error-re buffer "Error decrypting buffer"))
 329       (cons nil nil)))))
 330
 331 (defun mc-pgp-sign-region (start end &optional id unclear)
 332   (let ((process-environment process-environment)
 333         (buffer (get-buffer-create mc-buffer-name))
 334         passwd args key)
 335     (setq key (mc-pgp-lookup-key (or id mc-pgp-user-id)))
 336     (if (not key) (error "No key available for signing."))
 337     (setq passwd
 338           (mc-activate-passwd
 339            (cdr key)
 340            (format "PGP passphrase for %s (%s): " (car key) (cdr key))))
 341     (setenv "PGPPASSFD" "0")
 342     (setq args
 343           (list
 344            "-fast" "+verbose=1" "+language=en"
 345             (format "+clearsig=%s" (if unclear "off" "on"))
 346             "+batchmode" "-u" (cdr key)))
 347     (if mc-pgp-comment
 348         (setq args (cons (format "+comment=%s" mc-pgp-comment) args)))
 349     (message "Signing as %s ..." (car key))
 350     (if (mc-process-region start end passwd mc-pgp-path args
 351                            'mc-pgp-generic-parser buffer)
 352         (progn
 353           (message "Signing as %s ... Done." (car key))
 354           t)
 355       nil)))
 356
 357 (defun mc-pgp-verify-parser (result)
 358   (cond ((eq result 0)
 359          (mc-message mc-pgp-sigok-re (current-buffer) "Good signature")
 360          t)
 361         ((eq result 1)
 362          (mc-message mc-pgp-error-re (current-buffer) "Bad signature")
 363          nil)
 364         (t
 365          (mc-message mc-pgp-error-re (current-buffer)
 366                      (format "PGP exited with status %d" result))
 367          nil)))
 368
 369 (defun mc-pgp-verify-region (start end &optional no-fetch)
 370   (let ((buffer (get-buffer-create mc-buffer-name))
 371         (obuf (current-buffer))
 372         args pgp-id)
 373     (setq args '("+verbose=1" "+batchmode" "+language=en" "-f"))
 374     (if mc-pgp-alternate-keyring
 375         (setq args (append args (list (format "+pubring=%s"
 376                                               mc-pgp-alternate-keyring)))))
 377     (message "Verifying...")
 378     (if (mc-process-region
 379          start end nil mc-pgp-path args 'mc-pgp-verify-parser buffer)
 380         t
 381       (save-excursion
 382         (set-buffer buffer)
 383         (goto-char (point-min))
 384         (if (and
 385              (not no-fetch)
 386              (re-search-forward mc-pgp-key-expected-re nil t)
 387              (setq pgp-id
 388                    (concat "0x" (buffer-substring-no-properties
 389                                  (match-beginning 1)
 390                                  (match-end 1))))
 391              (not (eq mc-pgp-always-fetch 'never))
 392              (or mc-pgp-always-fetch
 393                  (y-or-n-p
 394                   (format "Key %s not found; attempt to fetch? " pgp-id)))
 395              (mc-pgp-fetch-key (cons nil pgp-id))
 396              (set-buffer obuf))
 397             (mc-pgp-verify-region start end t)
 398           (mc-message mc-pgp-error-re buffer)
 399           nil)))))
 400
 401 (defun mc-pgp-insert-public-key (&optional id)
 402   (let ((buffer (get-buffer-create mc-buffer-name))
 403         args)
 404     (setq id (or id mc-pgp-user-id))
 405     (setq args (list "+verbose=1" "+batchmode" "+language=en" "-kxaf" id))
 406     (if mc-pgp-comment
 407         (setq args (cons (format "+comment=%s" mc-pgp-comment) args)))
 408     (if mc-pgp-alternate-keyring
 409         (setq args (append args (list (format "+pubring=%s"
 410                                               mc-pgp-alternate-keyring)))))
 411
 412     (if (mc-process-region (point) (point) nil mc-pgp-path
 413                            args 'mc-pgp-generic-parser buffer)
 414         (progn
 415           (mc-message "Key for user ID: .*" buffer)
 416           t))))
 417
 418 (defun mc-pgp-snarf-parser (result)
 419   (eq result 0))
 420
 421 (defun mc-pgp-snarf-keys (start end)
 422   ;; Returns number of keys found.
 423   (let ((buffer (get-buffer-create mc-buffer-name)) tmpstr args)
 424     (setq args '("+verbose=1" "+batchmode" "+language=en" "-kaf"))
 425     (if mc-pgp-alternate-keyring
 426         (setq args (append args (list (format "+pubring=%s"
 427                                               mc-pgp-alternate-keyring)))))
 428     (message "Snarfing...")
 429     (if (mc-process-region start end nil mc-pgp-path args
 430                            'mc-pgp-snarf-parser buffer)
 431         (save-excursion
 432           (set-buffer buffer)
 433           (goto-char (point-min))
 434           (if (re-search-forward mc-pgp-newkey-re nil t)
 435               (progn
 436                 (if mc-pgp-display-snarf-output (mc-display-buffer buffer))
 437                 (setq tmpstr (buffer-substring-no-properties
 438                               (match-beginning 1)
 439                               (match-end 1)))
 440                 (if (equal tmpstr "No")
 441                     0
 442                   (car (read-from-string tmpstr))))))
 443       (mc-display-buffer buffer)
 444       (mc-message mc-pgp-error-re buffer "Error snarfing PGP keys")
 445       0)))
 446
 447 (defun mc-scheme-pgp ()
 448   (list
 449    (cons 'encryption-func               'mc-pgp-encrypt-region)
 450    (cons 'decryption-func               'mc-pgp-decrypt-region)
 451    (cons 'signing-func                  'mc-pgp-sign-region)
 452    (cons 'verification-func             'mc-pgp-verify-region)
 453    (cons 'key-insertion-func            'mc-pgp-insert-public-key)
 454    (cons 'snarf-func                    'mc-pgp-snarf-keys)
 455    (cons 'msg-begin-line                mc-pgp-msg-begin-line)
 456    (cons 'msg-end-line                  mc-pgp-msg-end-line)
 457    (cons 'signed-begin-line             mc-pgp-signed-begin-line)
 458    (cons 'signed-end-line               mc-pgp-signed-end-line)
 459    (cons 'key-begin-line                mc-pgp-key-begin-line)
 460    (cons 'key-end-line                  mc-pgp-key-end-line)
 461    (cons 'user-id                       mc-pgp-user-id)))
 462
 463 ;;{{{ Key fetching
 464
 465 (defvar mc-pgp-always-fetch nil
 466   "*If t, always attempt to fetch missing keys, or never fetch if
 467 'never.")
 468
 469 (defvar mc-pgp-keyserver-url-template
 470   "/pks/lookup?op=get&search=%s"
 471   "The URL to pass to the keyserver.")
 472
 473 (defvar mc-pgp-keyserver-address "pgp.ai.mit.edu"
 474   "Host name of keyserver.")
 475
 476 (defvar mc-pgp-keyserver-port 11371
 477   "Port on which the keyserver's HTTP daemon lives.")
 478
 479 (defvar mc-pgp-fetch-timeout 20
 480   "*Timeout, in seconds, for any particular key fetch operation.")
 481
 482 (defvar mc-pgp-fetch-keyring-list nil
 483   "*List of strings which are filenames of public keyrings to search
 484 when fetching keys.")
 485
 486 (defsubst mc-pgp-buffer-get-key (buf)
 487   "Return the first key block in BUF as a string, or nil if none found."
 488   (save-excursion
 489     (let (start)
 490       (set-buffer buf)
 491       (goto-char (point-min))
 492       (and (re-search-forward mc-pgp-key-begin-line nil t)
 493            (setq start (match-beginning 0))
 494            (re-search-forward mc-pgp-key-end-line nil t)
 495            (buffer-substring-no-properties start (match-end 0))))))
 496
 497 (defun mc-pgp-fetch-from-keyrings (id)
 498   (let ((keyring-list mc-pgp-fetch-keyring-list)
 499         buf proc key)
 500     (unwind-protect
 501         (progn
 502           (message "Fetching %s from keyrings..." (or (cdr id) (car id)))
 503           (while (and (not key) keyring-list)
 504             (setq buf (generate-new-buffer " *mailcrypt temp*"))
 505             (setq proc
 506                   (start-process "*PGP*" buf mc-pgp-path "-kxaf"
 507                                  "+verbose=0" "+batchmode"
 508                                  (format "+pubring=%s" (car keyring-list))
 509                                  (or (cdr id) (car id))))
 510             ;; Because PGPPASSFD might be set
 511             (process-send-string proc "\r\n")
 512             (while (eq 'run (process-status proc))
 513               (accept-process-output proc 5))
 514             (setq key (mc-pgp-buffer-get-key buf))
 515             (setq keyring-list (cdr keyring-list)))
 516           key)
 517       (if buf (kill-buffer buf))
 518       (if (and proc (eq 'run (process-status proc)))
 519           (interrupt-process proc)))))
 520
 521 (defun mc-pgp-fetch-from-http (id)
 522   (let (buf connection)
 523     (unwind-protect
 524         (progn
 525           (message "Fetching %s via HTTP to %s..."
 526                    (or (cdr id) (car id)) mc-pgp-keyserver-address)
 527           (setq buf (generate-new-buffer " *mailcrypt temp*"))
 528           (setq connection
 529                 (open-network-stream "*key fetch*" buf mc-pgp-keyserver-address
 530                                      mc-pgp-keyserver-port))
 531           (process-send-string
 532            connection
 533            (concat "GET " (format mc-pgp-keyserver-url-template
 534                                   (or (cdr id) (car id))) "\r\n"))
 535           (while (and (eq 'open (process-status connection))
 536                       (accept-process-output connection mc-pgp-fetch-timeout)))
 537           (mc-pgp-buffer-get-key buf))
 538       (if buf (kill-buffer buf))
 539       (if connection (delete-process connection)))))
 540
 541 (defun mc-pgp-fetch-from-finger (id)
 542   (let (buf connection user host)
 543     (unwind-protect
 544         (and (car id)
 545              (string-match "^\\(.+\\)@\\([^@]+\\)$" (car id))
 546              (progn
 547                (message "Trying finger %s..." (car id))
 548                (setq user (substring (car id)
 549                                      (match-beginning 1) (match-end 1)))
 550                (setq host (substring (car id)
 551                                      (match-beginning 2) (match-end 2)))
 552                (setq buf (generate-new-buffer " *mailcrypt temp*"))
 553                (condition-case nil
 554                    (progn
 555                      (setq connection
 556                            (open-network-stream "*key fetch*" buf host 79))
 557                      (process-send-string connection
 558                                           (concat "/W " user "\r\n"))
 559                      (while
 560                          (and (eq 'open (process-status connection))
 561                               (accept-process-output connection
 562                                                      mc-pgp-fetch-timeout)))
 563                      (mc-pgp-buffer-get-key buf))
 564                  (error nil))))
 565       (if buf (kill-buffer buf))
 566       (if connection (delete-process connection)))))
 567
 568 (defvar mc-pgp-fetch-methods '(mc-pgp-fetch-from-keyrings
 569                                mc-pgp-fetch-from-finger
 570                                mc-pgp-fetch-from-http)
 571   "List of methods to try when attempting to fetch a key.  Each
 572 element is a function to call with an ID as argument.  See the
 573 documentation for the function mc-pgp-fetch-key for a description of
 574 the ID.")
 575
 576 (defun mc-pgp-fetch-key (&optional id)
 577   "Attempt to fetch a key for addition to PGP keyring.  Interactively,
 578 prompt for string matching key to fetch.
 579
 580 Non-interactively, ID must be a pair.  The CAR must be a bare Email
 581 address and the CDR a keyID (with \"0x\" prefix).  Either, but not
 582 both, may be nil.
 583
 584 Return t if we think we were successful; nil otherwise.  Note that nil
 585 is not necessarily an error, since we may have merely fired off an Email
 586 request for the key."
 587   (interactive)
 588   (let ((methods mc-pgp-fetch-methods)
 589         (process-connection-type nil) key proc buf args)
 590     (if (null id)
 591         (setq id (cons (read-string "Fetch key for: ") nil)))
 592     (while (and (not key) methods)
 593       (setq key (funcall (car methods) id))
 594       (setq methods (cdr methods)))
 595     (if (not (stringp key))
 596         (progn
 597           (message "Key not found.")
 598           nil)
 599       ;; Maybe I'll do this right someday.
 600       (unwind-protect
 601           (save-window-excursion
 602             (setq buf (generate-new-buffer " *PGP Key Info*"))
 603             (pop-to-buffer buf)
 604             (if (< (window-height) (/ (frame-height) 2))
 605                 (enlarge-window (- (/ (frame-height) 2)
 606                                    (window-height))))
 607             (setq args '("-f" "+verbose=0" "+batchmode"))
 608             (if mc-pgp-alternate-keyring
 609                 (setq args
 610                       (append args (list (format "+pubring=%s"
 611                                                  mc-pgp-alternate-keyring)))))
 612
 613             (setq proc (apply 'start-process "*PGP*" buf mc-pgp-path args))
 614             ;; Because PGPPASSFD might be set
 615             (process-send-string proc "\r\n")
 616             (process-send-string proc key)
 617             (process-send-string proc "\r\n")
 618             (process-send-eof proc)
 619             (set-buffer buf)
 620             (while (eq 'run (process-status proc))
 621               (accept-process-output proc 5)
 622               (goto-char (point-min)))
 623             (if (y-or-n-p "Add this key to keyring? ")
 624                 (progn
 625                   (setq args (append args '("-ka")))
 626                   (setq proc
 627                         (apply 'start-process "*PGP*" buf mc-pgp-path args))
 628                   ;; Because PGPPASSFD might be set
 629                   (process-send-string proc "\r\n")
 630                   (process-send-string proc key)
 631                   (process-send-string proc "\r\n")
 632                   (process-send-eof proc)
 633                   (while (eq 'run (process-status proc))
 634                     (accept-process-output proc 5))
 635                   t)))
 636         (if buf (kill-buffer buf))))))
 637
 638 ;;}}}