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