Mercurial > hg > xemacs-beta

comparison lisp/w3/socks.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 ;;; socks.el --- A Socks v5 Client for Emacs
2 ;; Author: wmperry
3 ;; Created: 1996/12/14 06:59:31
4 ;; Version: 1.2
5 ;; Keywords: comm, firewalls
6
7 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
8 ;;; Copyright (c) 1996 by William M. Perry (wmperry@cs.indiana.edu)
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 ;;; This is an implementation of the SOCKS v5 protocol as defined in
28 ;;; RFC 1928.
29 ;;;
30 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
31 (require 'cl)
32
33 (defconst socks-version 5)
34 (defvar socks-debug nil)
35
36 ;; Common socks v5 commands
37 (defconst socks-connect-command 1)
38 (defconst socks-bind-command 2)
39 (defconst socks-udp-associate-command 3)
40
41 ;; Miscellaneous other socks constants
42 (defconst socks-authentication-null 0)
43 (defconst socks-authentication-failure 255)
44
45 ;; Response codes
46 (defconst socks-response-success 0)
47 (defconst socks-response-general-failure 1)
48 (defconst socks-response-access-denied 2)
49 (defconst socks-response-network-unreachable 3)
50 (defconst socks-response-host-unreachable 4)
51 (defconst socks-response-connection-refused 5)
52 (defconst socks-response-ttl-expired 6)
53 (defconst socks-response-cmd-not-supported 7)
54 (defconst socks-response-address-not-supported 8)
55
56 (defvar socks-errors
57 '("Succeeded"
58 "General SOCKS server failure"
59 "Connection not allowed by ruleset"
60 "Network unreachable"
61 "Host unreachable"
62 "Connection refused"
63 "Time-to-live expired"
64 "Command not supported"
65 "Address type not supported"))
66
67 ;; The socks v5 address types
68 (defconst socks-address-type-v4 1)
69 (defconst socks-address-type-name 3)
70 (defconst socks-address-type-v6 4)
71
72 ;; Base variables
73 (defvar socks-host (or (getenv "SOCKS5_SERVER") "socks"))
74 (defvar socks-port (or (getenv "SOCKS5_PORT") 1080))
75 (defvar socks-timeout 5)
76 (defvar socks-connections (make-hash-table :size 13))
77
78 ;; Miscellaneous stuff for authentication
79 (defvar socks-authentication-methods nil)
80 (defvar socks-username (user-login-name))
81 (defvar socks-password nil)
82
83 (defun socks-register-authentication-method (id desc callback)
84 (let ((old (assq id socks-authentication-methods)))
85 (if old
86 (setcdr old (cons desc callback))
87 (setq socks-authentication-methods
88 (cons (cons id (cons desc callback))
89 socks-authentication-methods)))))
90
91 (defun socks-unregister-authentication-method (id)
92 (let ((old (assq id socks-authentication-methods)))
93 (if old
94 (setq socks-authentication-methods
95 (delq old socks-authentication-methods)))))
96
97 (socks-register-authentication-method 0 "No authentication" 'identity)
98
99 (defun socks-build-auth-list ()
100 (let ((num 0)
101 (retval ""))
102 (mapcar
103 (function
104 (lambda (x)
105 (if (fboundp (cdr (cdr x)))
106 (setq retval (format "%s%c" retval (car x))
107 num (1+ num)))))
108 socks-authentication-methods)
109 (format "%c%s" num retval)))
110
111 (defconst socks-state-waiting-for-auth 0)
112 (defconst socks-state-submethod-negotiation 1)
113 (defconst socks-state-authenticated 2)
114 (defconst socks-state-waiting 3)
115 (defconst socks-state-connected 4)
116
117 (defmacro socks-wait-for-state-change (proc htable cur-state)
118 (`
119 (while (and (= (cl-gethash 'state (, htable)) (, cur-state))
120 (memq (process-status (, proc)) '(run open)))
121 (accept-process-output (, proc) socks-timeout))))
122
123 (defun socks-filter (proc string)
124 (let ((info (cl-gethash proc socks-connections))
125 state desired-len)
126 (or info (error "socks-filter called on non-SOCKS connection %S" proc))
127 (setq state (cl-gethash 'state info))
128 (cond
129 ((= state socks-state-waiting-for-auth)
130 (cl-puthash 'scratch (concat string (cl-gethash 'scratch info)) info)
131 (setq string (cl-gethash 'scratch info))
132 (if (< (length string) 2)
133 nil ; We need to spin some more
134 (cl-puthash 'authtype (aref string 1) info)
135 (cl-puthash 'scratch (substring string 2 nil) info)
136 (cl-puthash 'state socks-state-submethod-negotiation info)))
137 ((= state socks-state-submethod-negotiation)
138 )
139 ((= state socks-state-authenticated)
140 )
141 ((= state socks-state-waiting)
142 (cl-puthash 'scratch (concat string (cl-gethash 'scratch info)) info)
143 (setq string (cl-gethash 'scratch info))
144 (if (< (length string) 4)
145 nil
146 (setq desired-len
147 (+ 6 ; Standard socks header
148 (cond
149 ((= (aref string 3) socks-address-type-v4) 4)
150 ((= (aref string 3) socks-address-type-v6) 16)
151 ((= (aref string 3) socks-address-type-name)
152 (if (< (length string) 5)
153 255
154 (+ 1 (aref string 4)))))))
155 (if (< (length string) desired-len)
156 nil ; Need to spin some more
157 (cl-puthash 'state socks-state-connected info)
158 (cl-puthash 'reply (aref string 1) info)
159 (cl-puthash 'response string info))))
160 ((= state socks-state-connected)
161 )
162 )
163 )
164 )
165
166 (defun socks-open-connection (&optional host port)
167 (interactive)
168 (setq host (or host socks-host)
169 port (or port socks-port))
170 (save-excursion
171 (let ((proc (socks-original-open-network-stream "socks"
172 nil
173 host port))
174 (info (make-hash-table :size 13))
175 (authtype nil))
176
177 ;; Initialize process and info about the process
178 (set-process-filter proc 'socks-filter)
179 (process-kill-without-query proc)
180 (cl-puthash proc info socks-connections)
181 (cl-puthash 'state socks-state-waiting-for-auth info)
182 (cl-puthash 'authtype socks-authentication-failure info)
183
184 ;; Send what we think we can handle for authentication types
185 (process-send-string proc (format "%c%s" socks-version
186 (socks-build-auth-list)))
187
188 ;; Basically just do a select() until we change states.
189 (socks-wait-for-state-change proc info socks-state-waiting-for-auth)
190 (setq authtype (cl-gethash 'authtype info))
191 (cond
192 ((= authtype socks-authentication-null)
193 (and socks-debug (message "No authentication necessary")))
194 ((= authtype socks-authentication-failure)
195 (error "No acceptable authentication methods found."))
196 (t
197 (let* ((auth-type (char-int (cl-gethash 'authtype info)))
198 (auth-handler (assoc auth-type socks-authentication-methods))
199 (auth-func (and auth-handler (cdr (cdr auth-handler))))
200 (auth-desc (and auth-handler (car (cdr auth-handler)))))
201 (set-process-filter proc nil)
202 (if (and auth-func (fboundp auth-func)
203 (funcall auth-func proc))
204 (message "Successfully authenticated using: %s" auth-desc)
205 (delete-process proc)
206 (error "Failed to use auth method: %s (%d)"
207 (or auth-desc "Unknown") auth-type))
208 )
209 )
210 )
211 (cl-puthash 'state socks-state-authenticated info)
212 (set-process-filter proc 'socks-filter)
213 proc)))
214
215 (defun socks-send-command (proc command atype address port)
216 (let ((addr (case atype
217 (socks-address-type-v4 address)
218 (socks-address-type-v6 address)
219 (t
220 (format "%c%s" (length address) address))))
221 (info (cl-gethash proc socks-connections)))
222 (or info (error "socks-send-command called on non-SOCKS connection %S"
223 proc))
224 (cl-puthash 'state socks-state-waiting info)
225 (process-send-string proc
226 (format
227 "%c%c%c%c%s%c%c"
228 socks-version ; version
229 command ; command
230 0 ; reserved
231 atype ; address type
232 addr ; address
233 (lsh port -8) ; port, high byte
234 (- port (lsh (lsh port -8) 8)) ; port, low byte
235 ))
236 (socks-wait-for-state-change proc info socks-state-waiting)
237 (if (= (cl-gethash 'reply info) socks-response-success)
238 nil ; Sweet sweet success!
239 (delete-process proc)
240 (error "%s" (nth (cl-gethash 'reply info) socks-errors)))
241 proc))
242
243
244 ;; Replacement functions for open-network-stream, etc.
245 (defvar socks-noproxy nil
246 "*List of regexps matching hosts that we should not socksify connections to")
247
248 (defun socks-find-route (host service)
249 (let ((route (cons socks-host socks-port))
250 (noproxy socks-noproxy))
251 (while noproxy
252 (if (string-match (car noproxy) host)
253 (setq route nil
254 noproxy nil))
255 (setq noproxy (cdr noproxy)))
256 route))
257
258 (if (fboundp 'socks-original-open-network-stream)
259 nil ; Do nothing, we've been here already
260 (fset 'socks-original-open-network-stream
261 (symbol-function 'open-network-stream))
262 (fset 'open-network-stream 'socks-open-network-stream))
263
264 (defvar socks-services-file "/etc/services")
265 (defvar socks-tcp-services (make-hash-table :size 13 :test 'equal))
266 (defvar socks-udp-services (make-hash-table :size 13 :test 'equal))
267
268 (defun socks-parse-services ()
269 (if (not (and (file-exists-p socks-services-file)
270 (file-readable-p socks-services-file)))
271 (error "Could not find services file: %s" socks-services-file))
272 (save-excursion
273 (clrhash socks-tcp-services)
274 (clrhash socks-udp-services)
275 (set-buffer (get-buffer-create " *socks-tmp*"))
276 (erase-buffer)
277 (insert-file-contents socks-services-file)
278 ;; Nuke comments
279 (goto-char (point-min))
280 (while (re-search-forward "#.*" nil t)
281 (replace-match ""))
282 ;; Nuke empty lines
283 (goto-char (point-min))
284 (while (re-search-forward "^[ \t\n]+" nil t)
285 (replace-match ""))
286 ;; Now find all the lines
287 (goto-char (point-min))
288 (let (name port type)
289 (while (re-search-forward "^\\([^ \t]+\\)[ \t]+\\([0-9]+\\)/\\([a-z]+\\)"
290 nil t)
291 (setq name (downcase (match-string 1))
292 port (string-to-int (match-string 2))
293 type (downcase (match-string 3)))
294 (cl-puthash name port (if (equal type "udp")
295 socks-udp-services
296 socks-tcp-services))))))
297
298 (defun socks-find-services-entry (service &optional udp)
299 "Return the port # associated with SERVICE"
300 (if (= (hash-table-count socks-tcp-services) 0)
301 (socks-parse-services))
302 (cl-gethash (downcase service)
303 (if udp socks-udp-services socks-tcp-services)))
304
305 (defun socks-open-network-stream (name buffer host service)
306 (let* ((route (socks-find-route host service))
307 proc info)
308 (if (not route)
309 (socks-original-open-network-stream name buffer host service)
310 (setq proc (socks-open-connection (car route) (cdr route))
311 info (cl-gethash proc socks-connections))
312 (socks-send-command proc socks-connect-command
313 socks-address-type-name
314 host
315 (if (stringp service)
316 (socks-find-services-entry service)
317 service))
318 (cl-puthash 'buffer buffer info)
319 (cl-puthash 'host host info)
320 (cl-puthash 'service host info)
321 (set-process-filter proc nil)
322 (set-process-buffer proc (if buffer (get-buffer-create buffer)))
323 proc)))
324
325 ;; Authentication modules go here
326
327 ;; Basic username/password authentication, ala RFC 1929
328 ;; To enable username/password authentication, uncomment the following
329 ;; lines:
330 ;;
331 ;; (socks-register-authentication-method 2 "Username/Password"
332 ;; 'socks-username/password-auth)
333
334 (defconst socks-username/password-auth-version 1)
335
336 (if (not (fboundp 'char-int))
337 (fset 'char-int 'identity))
338
339 (defun socks-username/password-auth-filter (proc str)
340 (let ((info (cl-gethash proc socks-connections))
341 state desired-len)
342 (or info (error "socks-filter called on non-SOCKS connection %S" proc))
343 (setq state (cl-gethash 'state info))
344 (cl-puthash 'scratch (concat (cl-gethash 'scratch info) str) info)
345 (if (< (length (cl-gethash 'scratch info)) 2)
346 nil
347 (cl-puthash 'password-auth-status (char-int
348 (aref (cl-gethash 'scratch info) 1))
349 info)
350 (cl-puthash 'state socks-state-authenticated info))))
351
352 (defun socks-username/password-auth (proc)
353 (if (not socks-password)
354 (setq socks-password (read-passwd
355 (format "Password for %s@%s: "
356 socks-username socks-host))))
357 (let* ((info (cl-gethash proc socks-connections))
358 (state (cl-gethash 'state info)))
359 (cl-puthash 'scratch "" info)
360 (set-process-filter proc 'socks-username/password-auth-filter)
361 (process-send-string proc
362 (format "%c%c%s%c%s"
363 socks-username/password-auth-version
364 (length socks-username)
365 socks-username
366 (length socks-password)
367 socks-password))
368 (socks-wait-for-state-change proc info state)
369 (= (cl-gethash 'password-auth-status info) 0)))
370
371
372 ;; More advanced GSS/API stuff, not yet implemented - volunteers?
373 ;; (socks-register-authentication-method 1 "GSS/API" 'socks-gssapi-auth)
374
375 (defun socks-gssapi-auth (proc)
376 nil)
377
378
379 ;; CHAP stuff
380 ;; (socks-register-authentication-method 3 "CHAP" 'socks-chap-auth)
381 (defun socks-chap-auth (proc)
382 nil)
383
384 (provide 'socks)