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