Mercurial > hg > xemacs-beta

comparison lisp/url/url-pgp.el @ 0:376386a54a3c r19-14

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r19-14
author cvs
date Mon, 13 Aug 2007 08:45:50 +0200
parents
children
comparison
equal deleted inserted replaced
-1:000000000000 0:376386a54a3c
1 ;;; url-pgp.el,v --- PGP Uniform Resource Locator retrieval code
2 ;; Author: wmperry
3 ;; Created: 1996/05/24 15:27:10
4 ;; Version: 1.3
5 ;; Keywords: comm, data, processes
6
7 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
8 ;;; Copyright (c) 1993, 1994, 1995 by William M. Perry (wmperry@spry.com)
9 ;;;
10 ;;; This file is not part of GNU Emacs, but the same permissions apply.
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
24 ;;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
25 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
26
27 (require 'url-vars)
28 (require 'url-parse)
29
30 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
31 ;;; UUencoding
32 ;;; ----------
33 ;;; These functions are needed for the (RI)PEM encoding. PGP can
34 ;;; handle binary data, but (RI)PEM requires that it be uuencoded
35 ;;; first, or it will barf severely. How rude.
36 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
37 (defun url-uuencode-buffer (&optional buff)
38 "UUencode buffer BUFF, with a default of the current buffer."
39 (setq buff (or buff (current-buffer)))
40 (save-excursion
41 (set-buffer buff)
42 (url-lazy-message "UUencoding...")
43 (call-process-region (point-min) (point-max)
44 url-uuencode-program t t nil "url-temp-file")
45 (url-lazy-message "UUencoding... done.")))
46
47 (defun url-uudecode-buffer (&optional buff)
48 "UUdecode buffer BUFF, with a default of the current buffer."
49 (setq buff (or buff (current-buffer)))
50 (let ((newname (url-generate-unique-filename)))
51 (save-excursion
52 (set-buffer buff)
53 (goto-char (point-min))
54 (re-search-forward "^begin [0-9][0-9][0-9] \\(.*\\)$" nil t)
55 (replace-match (concat "begin 600 " newname))
56 (url-lazy-message "UUdecoding...")
57 (call-process-region (point-min) (point-max) url-uudecode-program)
58 (url-lazy-message "UUdecoding...")
59 (erase-buffer)
60 (insert-file-contents-literally newname)
61 (url-lazy-message "UUdecoding... done.")
62 (condition-case ()
63 (delete-file newname)
64 (error nil)))))
65
66 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
67 ;;; Decoding PGP/PEM responses
68 ;;; --------------------------
69 ;;; A PGP/PEM encrypted/signed response contains all the real headers,
70 ;;; so this is just a quick decrypt-then-reparse hack.
71 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
72 (defun url-decode-pgp/pem (arg)
73 "Decode a pgp/pem response from an HTTP/1.0 server.
74 This expects the decoded message to contain all the necessary HTTP/1.0 headers
75 to correctly act on the decoded message (new content-type, etc)."
76 (mc-decrypt-message)
77 (url-parse-mime-headers))
78
79 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
80 ;;; PGP/PEM Encryption
81 ;;; ------------------
82 ;;; This implements the highly secure PGP/PEM encrypted requests, as
83 ;;; specified by NCSA and CERN.
84 ;;;
85 ;;; The complete online spec of this scheme was done by Tony Sanders
86 ;;; <sanders@bsdi.com>, and can be seen at
87 ;;; http://www.bsdi.com/HTTP:TNG/ripem-http.txt
88 ;;;
89 ;;; This section of code makes use of the EXCELLENT mailcrypt.el
90 ;;; package by Jin S Choi (jsc@mit.edu)
91 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
92
93 (defun url-public-key-exists (entity scheme)
94 "Return t iff a key for ENTITY exists using public key system SCHEME.
95 ENTITY is the username/hostname combination we are checking for.
96 SCHEME is a symbol representing what public key encryption program to use.
97 Currently only 'pgp (Pretty Good Privacy) and 'pem (RIPEM) are
98 recognized."
99 (let (retval)
100 (save-excursion
101 (cond
102 ((eq 'pgp scheme) ; PGP encryption
103 (set-buffer (get-buffer-create " *keytmp*"))
104 (erase-buffer)
105 (call-process mc-pgp-path nil t nil "+batchmode" "-kxaf" entity)
106 (goto-char (point-min))
107 (setq retval (search-forward mc-pgp-key-begin-line nil t)))
108 ((eq 'pem scheme) ; PEM encryption
109 (set-buffer (find-file-noselect mc-ripem-pubkeyfile))
110 (goto-char (point-min))
111 (setq retval (search-forward entity nil t)))
112 (t
113 (url-warn 'security
114 (format
115 "Bad value for SCHEME in url-public-key-exists %s"
116 scheme))))
117 (kill-buffer (current-buffer)))
118 retval))
119
120 (defun url-get-server-keys (entity &optional scheme)
121 "Make sure the key for ENTITY exists using SCHEME.
122 ENTITY is the username/hostname combination to get the info for.
123 This should be a string you could pass to 'finger'.
124 SCHEME is a symbol representing what public key encryption program to use.
125 Currently only 'pgp (Pretty Good Privacy) and 'pem (RIPEM) are
126 recognized."
127 (or scheme (setq scheme mc-default-scheme))
128 (save-excursion
129 (cond
130 ((url-public-key-exists entity scheme) nil)
131 (t
132 (string-match "\\([^@]+\\)@\\(.*\\)" entity)
133 (let ((url-working-buffer " *url-get-keys*"))
134 (url-retrieve (format "gopher://%s:79/0%s/w" (url-match entity 1)
135 (url-match entity 2)))
136 (mc-snarf-keys)
137 (kill-buffer url-working-buffer))))))
138
139 (defun url-fetch-with-pgp (url recipient type)
140 "Retrieve a document with public-key authentication.
141 URL is the url to request from the server.
142 RECIPIENT is the server's entity name (usually webmaster@host)
143 TYPE is a symbol representing what public key encryption program to use.
144 Currently only 'pgp (Pretty Good Privacy) and 'pem (RIPEM) are
145 recognized."
146 (or noninteractive (require 'mailcrypt))
147 (let ((request (url-create-mime-request url "PGP-Redirect"))
148 (url-request-data nil)
149 (url-request-extra-headers nil))
150 (save-excursion
151 (url-get-server-keys recipient type)
152 (set-buffer (get-buffer-create " *url-encryption*"))
153 (erase-buffer)
154 (insert "\n\n" mail-header-separator "\n" request)
155 (mc-encrypt-message recipient type)
156 (goto-char (point-min))
157 (if (re-search-forward (concat "\n" mail-header-separator "\n") nil t)
158 (delete-region (point-min) (point)))
159 (setq url-request-data (buffer-string)
160 url-request-extra-headers
161 (list (cons "Authorized" (format "%s entity=\"%s\""
162 (cond
163 ((eq type 'pgp) "PGP")
164 ((eq type 'pem) "PEM"))
165 url-pgp/pem-entity))
166 (cons "Content-type" (format "application/x-www-%s-reply"
167 (cond
168 ((eq type 'pgp) "pgp")
169 ((eq type 'pem) "pem")))))))
170 (kill-buffer " *url-encryption*")
171 (url-retrieve (url-expand-file-name "/") t)))
172
173 (provide 'url-pgp)