1 ;;; socks.el --- A Socks v5 Client for Emacs
3 ;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2002,
4 ;; 2007, 2008 Free Software Foundation, Inc.
6 ;; Author: William M. Perry <wmperry@gnu.org>
7 ;; Dave Love <fx@gnu.org>
8 ;; Keywords: comm, firewalls
10 ;; This file is part of GNU Emacs.
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 3, or (at your option)
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.
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 the
24 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
25 ;; Boston, MA 02110-1301, USA.
29 ;; This is an implementation of the SOCKS v5 protocol as defined in
33 ;; - Finish the redirection rules stuff
34 ;; - Implement composition of servers. Recursively evaluate the
35 ;; redirection rules and do SOCKS-over-HTTP and SOCKS-in-SOCKS
41 (if (not (fboundp 'split-string
))
42 (defun split-string (string &optional pattern
)
43 "Return a list of substrings of STRING which are separated by PATTERN.
44 If PATTERN is omitted, it defaults to \"[ \\f\\t\\n\\r\\v]+\"."
46 (setq pattern
"[ \f\t\n\r\v]+"))
47 (let (parts (start 0))
48 (while (string-match pattern string start
)
49 (setq parts
(cons (substring string start
(match-beginning 0)) parts
)
51 (nreverse (cons (substring string start
) parts
)))))
52 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
54 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
55 (define-widget 'dynamic-choice
'menu-choice
56 "A pretty simple dynamic dropdown list"
60 :void
'(item :format
"invalid (%t)\n")
61 :value-create
's5-widget-value-create
62 :value-delete
'widget-children-value-delete
63 :value-get
'widget-choice-value-get
64 :value-inline
'widget-choice-value-inline
65 :mouse-down-action
'widget-choice-mouse-down-action
66 :action
'widget-choice-action
67 :error
"Make a choice"
68 :validate
'widget-choice-validate
69 :match
's5-dynamic-choice-match
70 :match-inline
's5-dynamic-choice-match-inline
)
72 (defun s5-dynamic-choice-match (widget value
)
73 (let ((choices (funcall (widget-get widget
:choice-function
)))
75 (while (and choices
(not found
))
76 (setq current
(car choices
)
78 found
(widget-apply current
:match value
)))
81 (defun s5-dynamic-choice-match-inline (widget value
)
82 (let ((choices (funcall (widget-get widget
:choice-function
)))
84 (while (and choices
(not found
))
85 (setq current
(car choices
)
87 found
(widget-match-inline current value
)))
90 (defun s5-widget-value-create (widget)
91 (let ((choices (funcall (widget-get widget
:choice-function
)))
92 (value (widget-get widget
:value
)))
94 (widget-put widget
:value
(widget-value (car choices
))))
95 (widget-put widget
:args choices
)
96 (widget-choice-value-create widget
)))
98 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
99 ;;; Customization support
100 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
106 '(defcustom socks-server-aliases nil
107 "A list of server aliases for use in access control and filtering rules."
109 :type
'(repeat (list :format
"%v"
110 :value
("" "" 1080 5)
111 (string :tag
"Alias")
112 (string :tag
"Hostname/IP Address")
113 (integer :tag
"Port #")
114 (choice :tag
"SOCKS Version"
115 (integer :tag
"SOCKS v4" :value
4)
116 (integer :tag
"SOCKS v5" :value
5)))))
118 '(defcustom socks-network-aliases
119 '(("Anywhere" (netmask "0.0.0.0" "0.0.0.0")))
120 "A list of network aliases for use in subsequent rules."
122 :type
'(repeat (list :format
"%v"
123 :value
(netmask "" "255.255.255.0")
124 (string :tag
"Alias")
127 (list :tag
"IP address range"
128 (const :format
"" :value range
)
131 (list :tag
"IP address/netmask"
132 (const :format
"" :value netmask
)
133 (string :tag
"IP Address")
134 (string :tag
"Netmask"))
135 (list :tag
"Domain Name"
136 (const :format
"" :value domain
)
137 (string :tag
"Domain name"))
138 (list :tag
"Unique hostname/IP address"
139 (const :format
"" :value exact
)
140 (string :tag
"Hostname/IP Address"))))))
142 '(defun s5-servers-filter ()
143 (if socks-server-aliases
144 (mapcar (lambda (x) (list 'const
:tag
(car x
) :value
(car x
))) s5-server-aliases
)
145 '((const :tag
"No aliases defined" :value nil
))))
147 '(defun s5-network-aliases-filter ()
148 (mapcar (lambda (x) (list 'const
:tag
(car x
) :value
(car x
)))
149 socks-network-aliases
))
151 '(defcustom socks-redirection-rules
153 "A list of redirection rules."
155 :type
'(repeat (list :format
"%v"
156 :value
("Anywhere" nil
)
157 (dynamic-choice :choice-function s5-network-aliases-filter
158 :tag
"Destination network")
160 :tag
"Connection type"
161 (const :tag
"Direct connection" :value nil
)
162 (dynamic-choice :format
"%t: %[%v%]"
163 :choice-function s5-servers-filter
164 :tag
"Proxy chain via")))))
166 (defcustom socks-server
167 (list "Default server" "socks" 1080 5)
171 (string :format
"" :value
"Default server")
172 (string :tag
"Server")
173 (integer :tag
"Port")
174 (radio-button-choice :tag
"SOCKS Version"
176 (const :tag
"SOCKS v4 " :format
"%t" :value
4)
177 (const :tag
"SOCKS v5" :format
"%t" :value
5))))
180 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
181 ;;; Get down to the nitty gritty
182 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
183 (defconst socks-version
5)
184 (defvar socks-debug nil
)
186 ;; Common socks v5 commands
187 (defconst socks-connect-command
1)
188 (defconst socks-bind-command
2)
189 (defconst socks-udp-associate-command
3)
191 ;; Miscellaneous other socks constants
192 (defconst socks-authentication-null
0)
193 (defconst socks-authentication-failure
255)
196 (defconst socks-response-success
0)
197 (defconst socks-response-general-failure
1)
198 (defconst socks-response-access-denied
2)
199 (defconst socks-response-network-unreachable
3)
200 (defconst socks-response-host-unreachable
4)
201 (defconst socks-response-connection-refused
5)
202 (defconst socks-response-ttl-expired
6)
203 (defconst socks-response-cmd-not-supported
7)
204 (defconst socks-response-address-not-supported
8)
208 "General SOCKS server failure"
209 "Connection not allowed by ruleset"
210 "Network unreachable"
213 "Time-to-live expired"
214 "Command not supported"
215 "Address type not supported"))
217 ;; The socks v5 address types
218 (defconst socks-address-type-v4
1)
219 (defconst socks-address-type-name
3)
220 (defconst socks-address-type-v6
4)
223 (defvar socks-timeout
5)
224 (defvar socks-connections
(make-hash-table :size
13))
226 ;; Miscellaneous stuff for authentication
227 (defvar socks-authentication-methods nil
)
228 (defvar socks-username
(user-login-name))
229 (defvar socks-password nil
)
231 (defun socks-register-authentication-method (id desc callback
)
232 (let ((old (assq id socks-authentication-methods
)))
234 (setcdr old
(cons desc callback
))
235 (setq socks-authentication-methods
236 (cons (cons id
(cons desc callback
))
237 socks-authentication-methods
)))))
239 (defun socks-unregister-authentication-method (id)
240 (let ((old (assq id socks-authentication-methods
)))
242 (setq socks-authentication-methods
243 (delq old socks-authentication-methods
)))))
245 (socks-register-authentication-method 0 "No authentication" 'identity
)
247 (defun socks-build-auth-list ()
253 (if (fboundp (cdr (cdr x
)))
254 (setq retval
(format "%s%c" retval
(car x
))
256 (reverse socks-authentication-methods
))
257 (format "%c%s" num retval
)))
259 (defconst socks-state-waiting-for-auth
0)
260 (defconst socks-state-submethod-negotiation
1)
261 (defconst socks-state-authenticated
2)
262 (defconst socks-state-waiting
3)
263 (defconst socks-state-connected
4)
265 (defmacro socks-wait-for-state-change
(proc htable cur-state
)
266 `(while (and (= (gethash 'state
,htable
) ,cur-state
)
267 (memq (process-status ,proc
) '(run open
)))
268 (accept-process-output ,proc socks-timeout
)))
270 (defun socks-filter (proc string
)
271 (let ((info (gethash proc socks-connections
))
272 state version desired-len
)
273 (or info
(error "socks-filter called on non-SOCKS connection %S" proc
))
274 (setq state
(gethash 'state info
))
276 ((= state socks-state-waiting-for-auth
)
277 (puthash 'scratch
(concat string
(gethash 'scratch info
)) info
)
278 (setq string
(gethash 'scratch info
))
279 (if (< (length string
) 2)
280 nil
; We need to spin some more
281 (puthash 'authtype
(aref string
1) info
)
282 (puthash 'scratch
(substring string
2 nil
) info
)
283 (puthash 'state socks-state-submethod-negotiation info
)))
284 ((= state socks-state-submethod-negotiation
)
286 ((= state socks-state-authenticated
)
288 ((= state socks-state-waiting
)
289 (puthash 'scratch
(concat string
(gethash 'scratch info
)) info
)
290 (setq string
(gethash 'scratch info
))
291 (setq version
(gethash 'server-protocol info
))
293 ((equal version
'http
)
294 (if (not (string-match "\r\n\r\n" string
))
295 nil
; Need to spin some more
296 (puthash 'state socks-state-connected info
)
297 (puthash 'reply
0 info
)
298 (puthash 'response string info
)))
300 (if (< (length string
) 2)
301 nil
; Can't know how much to read yet
303 (+ 4 ; address length
307 (if (< (length string
) desired-len
)
308 nil
; need to spin some more
309 (let ((response (aref string
1)))
312 (puthash 'state socks-state-connected info
)
313 (puthash 'reply response info
)
314 (puthash 'response string info
)))))
316 (if (< (length string
) 4)
319 (+ 6 ; Standard socks header
321 ((= (aref string
3) socks-address-type-v4
) 4)
322 ((= (aref string
3) socks-address-type-v6
) 16)
323 ((= (aref string
3) socks-address-type-name
)
324 (if (< (length string
) 5)
326 (+ 1 (aref string
4)))))))
327 (if (< (length string
) desired-len
)
328 nil
; Need to spin some more
329 (puthash 'state socks-state-connected info
)
330 (puthash 'reply
(aref string
1) info
)
331 (puthash 'response string info
))))))
332 ((= state socks-state-connected
)
338 (defun socks-open-connection (server-info)
341 (let ((proc (socks-original-open-network-stream "socks"
344 (nth 2 server-info
)))
345 (info (make-hash-table :size
13))
349 ;; Initialize process and info about the process
350 (set-process-filter proc
'socks-filter
)
351 (set-process-query-on-exit-flag proc nil
)
352 (puthash proc info socks-connections
)
353 (puthash 'state socks-state-waiting-for-auth info
)
354 (puthash 'authtype socks-authentication-failure info
)
355 (puthash 'server-protocol
(nth 3 server-info
) info
)
356 (puthash 'server-name
(nth 1 server-info
) info
)
357 (setq version
(nth 3 server-info
))
359 ((equal version
'http
)
360 ;; Don't really have to do any connection setup under http
363 ;; Don't really have to do any connection setup under v4
366 ;; Need to handle all the authentication crap under v5
367 ;; Send what we think we can handle for authentication types
368 (process-send-string proc
(format "%c%s" socks-version
369 (socks-build-auth-list)))
371 ;; Basically just do a select() until we change states.
372 (socks-wait-for-state-change proc info socks-state-waiting-for-auth
)
373 (setq authtype
(gethash 'authtype info
))
375 ((= authtype socks-authentication-null
)
376 (and socks-debug
(message "No authentication necessary")))
377 ((= authtype socks-authentication-failure
)
378 (error "No acceptable authentication methods found."))
380 (let* ((auth-type (gethash 'authtype info
))
381 (auth-handler (assoc auth-type socks-authentication-methods
))
382 (auth-func (and auth-handler
(cdr (cdr auth-handler
))))
383 (auth-desc (and auth-handler
(car (cdr auth-handler
)))))
384 (set-process-filter proc nil
)
385 (if (and auth-func
(fboundp auth-func
)
386 (funcall auth-func proc
))
388 (delete-process proc
)
389 (error "Failed to use auth method: %s (%d)"
390 (or auth-desc
"Unknown") auth-type
))
394 (puthash 'state socks-state-authenticated info
)
395 (set-process-filter proc
'socks-filter
)))
398 (defun socks-send-command (proc command atype address port
)
400 ((or (= atype socks-address-type-v4
)
401 (= atype socks-address-type-v6
))
403 ((= atype socks-address-type-name
)
404 (format "%c%s" (length address
) address
))
406 (error "Unkown address type: %d" atype
))))
407 (info (gethash proc socks-connections
))
409 (or info
(error "socks-send-command called on non-SOCKS connection %S"
411 (puthash 'state socks-state-waiting info
)
412 (setq version
(gethash 'server-protocol info
))
414 ((equal version
'http
)
415 (setq request
(format (eval-when-compile
417 "CONNECT %s:%d HTTP/1.0\r\n"
418 "User-Agent: Emacs/SOCKS v1.0\r\n"
421 ((equal atype socks-address-type-name
) address
)
423 (error "Unsupported address type for HTTP: %d" atype
)))
426 (setq request
(format
430 (lsh port -
8) ; port, high byte
431 (- port
(lsh (lsh port -
8) 8)) ; port, low byte
433 (user-full-name) ; username
434 0 ; terminate username
437 (setq request
(format
444 (lsh port -
8) ; port, high byte
445 (- port
(lsh (lsh port -
8) 8)) ; port, low byte
448 (error "Unknown protocol version: %d" version
)))
449 (process-send-string proc request
)
450 (socks-wait-for-state-change proc info socks-state-waiting
)
451 (process-status proc
)
452 (if (= (or (gethash 'reply info
) 1) socks-response-success
)
453 nil
; Sweet sweet success!
454 (delete-process proc
)
455 (error "SOCKS: %s" (nth (or (gethash 'reply info
) 1) socks-errors
)))
459 ;; Replacement functions for open-network-stream, etc.
460 (defvar socks-noproxy nil
461 "*List of regexps matching hosts that we should not socksify connections to")
463 (defun socks-find-route (host service
)
464 (let ((route socks-server
)
465 (noproxy socks-noproxy
))
467 (if (eq ?
! (aref (car noproxy
) 0))
468 (if (string-match (substring (car noproxy
) 1) host
)
470 (if (string-match (car noproxy
) host
)
473 (setq noproxy
(cdr noproxy
)))
476 (defvar socks-override-functions nil
477 "*Whether to overwrite the open-network-stream function with the SOCKSified
480 (if (fboundp 'socks-original-open-network-stream
)
481 nil
; Do nothing, we've been here already
482 (defalias 'socks-original-open-network-stream
483 (symbol-function 'open-network-stream
))
484 (if socks-override-functions
485 (defalias 'open-network-stream
'socks-open-network-stream
)))
487 (defvar socks-services-file
"/etc/services")
488 (defvar socks-tcp-services
(make-hash-table :size
13 :test
'equal
))
489 (defvar socks-udp-services
(make-hash-table :size
13 :test
'equal
))
491 (defun socks-parse-services ()
492 (if (not (and (file-exists-p socks-services-file
)
493 (file-readable-p socks-services-file
)))
494 (error "Could not find services file: %s" socks-services-file
))
495 (clrhash socks-tcp-services
)
496 (clrhash socks-udp-services
)
497 (with-current-buffer (get-buffer-create " *socks-tmp*")
499 (insert-file-contents socks-services-file
)
501 (goto-char (point-min))
502 (while (re-search-forward "#.*" nil t
)
505 (goto-char (point-min))
506 (while (re-search-forward "^[ \t\n]+" nil t
)
508 ;; Now find all the lines
509 (goto-char (point-min))
510 (let (name port type
)
511 (while (re-search-forward "^\\([^ \t]+\\)[ \t]+\\([0-9]+\\)/\\([a-z]+\\)"
513 (setq name
(downcase (match-string 1))
514 port
(string-to-number (match-string 2))
515 type
(downcase (match-string 3)))
516 (puthash name port
(if (equal type
"udp")
518 socks-tcp-services
))))))
520 (defun socks-find-services-entry (service &optional udp
)
521 "Return the port # associated with SERVICE"
522 (if (= (hash-table-count socks-tcp-services
) 0)
523 (socks-parse-services))
524 (gethash (downcase service
)
525 (if udp socks-udp-services socks-tcp-services
)))
527 (defun socks-open-network-stream (name buffer host service
)
528 (let* ((route (socks-find-route host service
))
529 proc info version atype
)
531 (socks-original-open-network-stream name buffer host service
)
532 (setq proc
(socks-open-connection route
)
533 info
(gethash proc socks-connections
)
534 version
(gethash 'server-protocol info
))
537 (setq host
(socks-nslookup-host host
))
538 (if (not (listp host
))
539 (error "Could not get IP address for: %s" host
))
540 (setq host
(apply 'format
"%c%c%c%c" host
))
541 (setq atype socks-address-type-v4
))
543 (setq atype socks-address-type-name
)))
544 (socks-send-command proc
545 socks-connect-command
548 (if (stringp service
)
549 (socks-find-services-entry service
)
551 (puthash 'buffer buffer info
)
552 (puthash 'host host info
)
553 (puthash 'service host info
)
554 (set-process-filter proc nil
)
555 (set-process-buffer proc
(if buffer
(get-buffer-create buffer
)))
558 ;; Authentication modules go here
560 ;; Basic username/password authentication, ala RFC 1929
561 (socks-register-authentication-method 2 "Username/Password"
562 'socks-username
/password-auth
)
564 (defconst socks-username
/password-auth-version
1)
566 (defun socks-username/password-auth-filter
(proc str
)
567 (let ((info (gethash proc socks-connections
)))
568 (or info
(error "socks-filter called on non-SOCKS connection %S" proc
))
569 (puthash 'scratch
(concat (gethash 'scratch info
) str
) info
)
570 (if (< (length (gethash 'scratch info
)) 2)
572 (puthash 'password-auth-status
(aref (gethash 'scratch info
) 1) info
)
573 (puthash 'state socks-state-authenticated info
))))
575 (defun socks-username/password-auth
(proc)
576 (let* ((info (gethash proc socks-connections
))
577 (state (gethash 'state info
)))
578 (if (not socks-password
)
579 (setq socks-password
(read-passwd
580 (format "Password for %s@%s: "
582 (gethash 'server-name info
)))))
583 (puthash 'scratch
"" info
)
584 (set-process-filter proc
'socks-username
/password-auth-filter
)
585 (process-send-string proc
587 socks-username
/password-auth-version
588 (length socks-username
)
590 (length socks-password
)
592 (socks-wait-for-state-change proc info state
)
593 (= (gethash 'password-auth-status info
) 0)))
596 ;; More advanced GSS/API stuff, not yet implemented - volunteers?
597 ;; (socks-register-authentication-method 1 "GSS/API" 'socks-gssapi-auth)
599 (defun socks-gssapi-auth (proc)
604 ;; (socks-register-authentication-method 3 "CHAP" 'socks-chap-auth)
605 (defun socks-chap-auth (proc)
610 ;; (socks-register-authentication-method 5 "CRAM" 'socks-cram-auth)
611 (defun socks-cram-auth (proc)
615 (defcustom socks-nslookup-program
"nslookup"
616 "*If non-NIL then a string naming the nslookup program."
617 :type
'(choice (const :tag
"None" :value nil
) string
)
620 (defun socks-nslookup-host (host)
621 "Attempt to resolve the given HOSTNAME using nslookup if possible."
622 (interactive "sHost: ")
623 (if socks-nslookup-program
624 (let ((proc (start-process " *nslookup*" " *nslookup*"
625 socks-nslookup-program host
))
627 (set-process-query-on-exit-flag proc nil
)
628 (with-current-buffer (process-buffer proc
)
630 (accept-process-output proc
)
631 (memq (process-status proc
) '(run open
))))
632 (goto-char (point-min))
633 (if (re-search-forward "Name:.*\nAddress\\(es\\)?: *\\([0-9.]+\\)$" nil t
)
635 (setq res
(buffer-substring (match-beginning 2)
637 res
(mapcar 'string-to-int
(split-string res
"\\.")))))
638 (kill-buffer (current-buffer)))
644 ;; arch-tag: 67aef0d9-f4f7-4056-89c3-b4c9bf93ce7f
645 ;;; socks.el ends here