|
0
|
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)
|
