Mercurial > hg > xemacs-beta

comparison lisp/w3/url-pgp.el @ 14:9ee227acff29 r19-15b90

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