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 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
107 '(defcustom socks-server-aliases nil
108 "A list of server aliases for use in access control and filtering rules."
110 :type '(repeat (list :format "%v"
111 :value ("" "" 1080 5)
112 (string :tag "Alias")
113 (string :tag "Hostname/IP Address")
114 (integer :tag "Port #")
115 (choice :tag "SOCKS Version"
116 (integer :tag "SOCKS v4" :value 4)
117 (integer :tag "SOCKS v5" :value 5)))))
119 '(defcustom socks-network-aliases
120 '(("Anywhere" (netmask "0.0.0.0" "0.0.0.0")))
121 "A list of network aliases for use in subsequent rules."
123 :type '(repeat (list :format "%v"
124 :value (netmask "" "255.255.255.0")
125 (string :tag "Alias")
128 (list :tag "IP address range"
129 (const :format "" :value range)
132 (list :tag "IP address/netmask"
133 (const :format "" :value netmask)
134 (string :tag "IP Address")
135 (string :tag "Netmask"))
136 (list :tag "Domain Name"
137 (const :format "" :value domain)
138 (string :tag "Domain name"))
139 (list :tag "Unique hostname/IP address"
140 (const :format "" :value exact)
141 (string :tag "Hostname/IP Address"))))))
143 '(defun s5-servers-filter ()
144 (if socks-server-aliases
145 (mapcar (lambda (x) (list 'const :tag (car x) :value (car x))) s5-server-aliases)
146 '((const :tag "No aliases defined" :value nil))))
148 '(defun s5-network-aliases-filter ()
149 (mapcar (lambda (x) (list 'const :tag (car x) :value (car x)))
150 socks-network-aliases))
152 '(defcustom socks-redirection-rules
154 "A list of redirection rules."
156 :type '(repeat (list :format "%v"
157 :value ("Anywhere" nil)
158 (dynamic-choice :choice-function s5-network-aliases-filter
159 :tag "Destination network")
161 :tag "Connection type"
162 (const :tag "Direct connection" :value nil)
163 (dynamic-choice :format "%t: %[%v%]"
164 :choice-function s5-servers-filter
165 :tag "Proxy chain via")))))
167 (defcustom socks-server
168 (list "Default server" "socks" 1080 5)
172 (string :format "" :value "Default server")
173 (string :tag "Server")
174 (integer :tag "Port")
175 (radio-button-choice :tag "SOCKS Version"
177 (const :tag "SOCKS v4 " :format "%t" :value 4)
178 (const :tag "SOCKS v5" :format "%t" :value 5))))
181 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
182 ;;; Get down to the nitty gritty
183 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
184 (defconst socks-version 5)
185 (defvar socks-debug nil)
187 ;; Common socks v5 commands
188 (defconst socks-connect-command 1)
189 (defconst socks-bind-command 2)
190 (defconst socks-udp-associate-command 3)
192 ;; Miscellaneous other socks constants
193 (defconst socks-authentication-null 0)
194 (defconst socks-authentication-failure 255)
197 (defconst socks-response-success 0)
198 (defconst socks-response-general-failure 1)
199 (defconst socks-response-access-denied 2)
200 (defconst socks-response-network-unreachable 3)
201 (defconst socks-response-host-unreachable 4)
202 (defconst socks-response-connection-refused 5)
203 (defconst socks-response-ttl-expired 6)
204 (defconst socks-response-cmd-not-supported 7)
205 (defconst socks-response-address-not-supported 8)
209 "General SOCKS server failure"
210 "Connection not allowed by ruleset"
211 "Network unreachable"
214 "Time-to-live expired"
215 "Command not supported"
216 "Address type not supported"))
218 ;; The socks v5 address types
219 (defconst socks-address-type-v4 1)
220 (defconst socks-address-type-name 3)
221 (defconst socks-address-type-v6 4)
224 (defvar socks-timeout 5)
225 (defvar socks-connections (make-hash-table :size 13))
227 ;; Miscellaneous stuff for authentication
228 (defvar socks-authentication-methods nil)
229 (defvar socks-username (user-login-name))
230 (defvar socks-password nil)
232 (defun socks-register-authentication-method (id desc callback)
233 (let ((old (assq id socks-authentication-methods)))
235 (setcdr old (cons desc callback))
236 (setq socks-authentication-methods
237 (cons (cons id (cons desc callback))
238 socks-authentication-methods)))))
240 (defun socks-unregister-authentication-method (id)
241 (let ((old (assq id socks-authentication-methods)))
243 (setq socks-authentication-methods
244 (delq old socks-authentication-methods)))))
246 (socks-register-authentication-method 0 "No authentication" 'identity)
248 (defun socks-build-auth-list ()
254 (if (fboundp (cdr (cdr x)))
255 (setq retval (format "%s%c" retval (car x))
257 (reverse socks-authentication-methods))
258 (format "%c%s" num retval)))
260 (defconst socks-state-waiting-for-auth 0)
261 (defconst socks-state-submethod-negotiation 1)
262 (defconst socks-state-authenticated 2)
263 (defconst socks-state-waiting 3)
264 (defconst socks-state-connected 4)
266 (defmacro socks-wait-for-state-change (proc htable cur-state)
267 `(while (and (= (gethash 'state ,htable) ,cur-state)
268 (memq (process-status ,proc) '(run open)))
269 (accept-process-output ,proc socks-timeout)))
271 (defun socks-filter (proc string)
272 (let ((info (gethash proc socks-connections))
273 state version desired-len)
274 (or info (error "socks-filter called on non-SOCKS connection %S" proc))
275 (setq state (gethash 'state info))
277 ((= state socks-state-waiting-for-auth)
278 (puthash 'scratch (concat string (gethash 'scratch info)) info)
279 (setq string (gethash 'scratch info))
280 (if (< (length string) 2)
281 nil ; We need to spin some more
282 (puthash 'authtype (aref string 1) info)
283 (puthash 'scratch (substring string 2 nil) info)
284 (puthash 'state socks-state-submethod-negotiation info)))
285 ((= state socks-state-submethod-negotiation)
287 ((= state socks-state-authenticated)
289 ((= state socks-state-waiting)
290 (puthash 'scratch (concat string (gethash 'scratch info)) info)
291 (setq string (gethash 'scratch info))
292 (setq version (gethash 'server-protocol info))
294 ((equal version 'http)
295 (if (not (string-match "\r\n\r\n" string))
296 nil ; Need to spin some more
297 (puthash 'state socks-state-connected info)
298 (puthash 'reply 0 info)
299 (puthash 'response string info)))
301 (if (< (length string) 2)
302 nil ; Can't know how much to read yet
304 (+ 4 ; address length
308 (if (< (length string) desired-len)
309 nil ; need to spin some more
310 (let ((response (aref string 1)))
313 (puthash 'state socks-state-connected info)
314 (puthash 'reply response info)
315 (puthash 'response string info)))))
317 (if (< (length string) 4)
320 (+ 6 ; Standard socks header
322 ((= (aref string 3) socks-address-type-v4) 4)
323 ((= (aref string 3) socks-address-type-v6) 16)
324 ((= (aref string 3) socks-address-type-name)
325 (if (< (length string) 5)
327 (+ 1 (aref string 4)))))))
328 (if (< (length string) desired-len)
329 nil ; Need to spin some more
330 (puthash 'state socks-state-connected info)
331 (puthash 'reply (aref string 1) info)
332 (puthash 'response string info))))))
333 ((= state socks-state-connected)
339 (declare-function socks-original-open-network-stream "socks") ; fset
341 (defvar socks-override-functions nil
342 "*Whether to overwrite the open-network-stream function with the SOCKSified
345 (if (fboundp 'socks-original-open-network-stream)
346 nil ; Do nothing, we've been here already
347 (defalias 'socks-original-open-network-stream
348 (symbol-function 'open-network-stream))
349 (if socks-override-functions
350 (defalias 'open-network-stream 'socks-open-network-stream)))
352 (defun socks-open-connection (server-info)
355 (let ((proc (socks-original-open-network-stream "socks"
358 (nth 2 server-info)))
359 (info (make-hash-table :size 13))
363 ;; Initialize process and info about the process
364 (set-process-filter proc 'socks-filter)
365 (set-process-query-on-exit-flag proc nil)
366 (puthash proc info socks-connections)
367 (puthash 'state socks-state-waiting-for-auth info)
368 (puthash 'authtype socks-authentication-failure info)
369 (puthash 'server-protocol (nth 3 server-info) info)
370 (puthash 'server-name (nth 1 server-info) info)
371 (setq version (nth 3 server-info))
373 ((equal version 'http)
374 ;; Don't really have to do any connection setup under http
377 ;; Don't really have to do any connection setup under v4
380 ;; Need to handle all the authentication crap under v5
381 ;; Send what we think we can handle for authentication types
382 (process-send-string proc (format "%c%s" socks-version
383 (socks-build-auth-list)))
385 ;; Basically just do a select() until we change states.
386 (socks-wait-for-state-change proc info socks-state-waiting-for-auth)
387 (setq authtype (gethash 'authtype info))
389 ((= authtype socks-authentication-null)
390 (and socks-debug (message "No authentication necessary")))
391 ((= authtype socks-authentication-failure)
392 (error "No acceptable authentication methods found."))
394 (let* ((auth-type (gethash 'authtype info))
395 (auth-handler (assoc auth-type socks-authentication-methods))
396 (auth-func (and auth-handler (cdr (cdr auth-handler))))
397 (auth-desc (and auth-handler (car (cdr auth-handler)))))
398 (set-process-filter proc nil)
399 (if (and auth-func (fboundp auth-func)
400 (funcall auth-func proc))
402 (delete-process proc)
403 (error "Failed to use auth method: %s (%d)"
404 (or auth-desc "Unknown") auth-type))
408 (puthash 'state socks-state-authenticated info)
409 (set-process-filter proc 'socks-filter)))
412 (defun socks-send-command (proc command atype address port)
414 ((or (= atype socks-address-type-v4)
415 (= atype socks-address-type-v6))
417 ((= atype socks-address-type-name)
418 (format "%c%s" (length address) address))
420 (error "Unkown address type: %d" atype))))
421 (info (gethash proc socks-connections))
423 (or info (error "socks-send-command called on non-SOCKS connection %S"
425 (puthash 'state socks-state-waiting info)
426 (setq version (gethash 'server-protocol info))
428 ((equal version 'http)
429 (setq request (format (eval-when-compile
431 "CONNECT %s:%d HTTP/1.0\r\n"
432 "User-Agent: Emacs/SOCKS v1.0\r\n"
435 ((equal atype socks-address-type-name) address)
437 (error "Unsupported address type for HTTP: %d" atype)))
440 (setq request (format
444 (lsh port -8) ; port, high byte
445 (- port (lsh (lsh port -8) 8)) ; port, low byte
447 (user-full-name) ; username
448 0 ; terminate username
451 (setq request (format
458 (lsh port -8) ; port, high byte
459 (- port (lsh (lsh port -8) 8)) ; port, low byte
462 (error "Unknown protocol version: %d" version)))
463 (process-send-string proc request)
464 (socks-wait-for-state-change proc info socks-state-waiting)
465 (process-status proc)
466 (if (= (or (gethash 'reply info) 1) socks-response-success)
467 nil ; Sweet sweet success!
468 (delete-process proc)
469 (error "SOCKS: %s" (nth (or (gethash 'reply info) 1) socks-errors)))
473 ;; Replacement functions for open-network-stream, etc.
474 (defvar socks-noproxy nil
475 "*List of regexps matching hosts that we should not socksify connections to")
477 (defun socks-find-route (host service)
478 (let ((route socks-server)
479 (noproxy socks-noproxy))
481 (if (eq ?! (aref (car noproxy) 0))
482 (if (string-match (substring (car noproxy) 1) host)
484 (if (string-match (car noproxy) host)
487 (setq noproxy (cdr noproxy)))
490 (defvar socks-services-file "/etc/services")
491 (defvar socks-tcp-services (make-hash-table :size 13 :test 'equal))
492 (defvar socks-udp-services (make-hash-table :size 13 :test 'equal))
494 (defun socks-parse-services ()
495 (if (not (and (file-exists-p socks-services-file)
496 (file-readable-p socks-services-file)))
497 (error "Could not find services file: %s" socks-services-file))
498 (clrhash socks-tcp-services)
499 (clrhash socks-udp-services)
500 (with-current-buffer (get-buffer-create " *socks-tmp*")
502 (insert-file-contents socks-services-file)
504 (goto-char (point-min))
505 (while (re-search-forward "#.*" nil t)
508 (goto-char (point-min))
509 (while (re-search-forward "^[ \t\n]+" nil t)
511 ;; Now find all the lines
512 (goto-char (point-min))
513 (let (name port type)
514 (while (re-search-forward "^\\([^ \t]+\\)[ \t]+\\([0-9]+\\)/\\([a-z]+\\)"
516 (setq name (downcase (match-string 1))
517 port (string-to-number (match-string 2))
518 type (downcase (match-string 3)))
519 (puthash name port (if (equal type "udp")
521 socks-tcp-services))))))
523 (defun socks-find-services-entry (service &optional udp)
524 "Return the port # associated with SERVICE"
525 (if (= (hash-table-count socks-tcp-services) 0)
526 (socks-parse-services))
527 (gethash (downcase service)
528 (if udp socks-udp-services socks-tcp-services)))
530 (defun socks-open-network-stream (name buffer host service)
531 (let* ((route (socks-find-route host service))
532 proc info version atype)
534 (socks-original-open-network-stream name buffer host service)
535 (setq proc (socks-open-connection route)
536 info (gethash proc socks-connections)
537 version (gethash 'server-protocol info))
540 (setq host (socks-nslookup-host host))
541 (if (not (listp host))
542 (error "Could not get IP address for: %s" host))
543 (setq host (apply 'format "%c%c%c%c" host))
544 (setq atype socks-address-type-v4))
546 (setq atype socks-address-type-name)))
547 (socks-send-command proc
548 socks-connect-command
551 (if (stringp service)
553 (socks-find-services-entry service)
554 (error "Unknown service: %s" service))
556 (puthash 'buffer buffer info)
557 (puthash 'host host info)
558 (puthash 'service host info)
559 (set-process-filter proc nil)
560 (set-process-buffer proc (if buffer (get-buffer-create buffer)))
563 ;; Authentication modules go here
565 ;; Basic username/password authentication, ala RFC 1929
566 (socks-register-authentication-method 2 "Username/Password"
567 'socks-username/password-auth)
569 (defconst socks-username/password-auth-version 1)
571 (defun socks-username/password-auth-filter (proc str)
572 (let ((info (gethash proc socks-connections)))
573 (or info (error "socks-filter called on non-SOCKS connection %S" proc))
574 (puthash 'scratch (concat (gethash 'scratch info) str) info)
575 (if (< (length (gethash 'scratch info)) 2)
577 (puthash 'password-auth-status (aref (gethash 'scratch info) 1) info)
578 (puthash 'state socks-state-authenticated info))))
580 (defun socks-username/password-auth (proc)
581 (let* ((info (gethash proc socks-connections))
582 (state (gethash 'state info)))
583 (if (not socks-password)
584 (setq socks-password (read-passwd
585 (format "Password for %s@%s: "
587 (gethash 'server-name info)))))
588 (puthash 'scratch "" info)
589 (set-process-filter proc 'socks-username/password-auth-filter)
590 (process-send-string proc
592 socks-username/password-auth-version
593 (length socks-username)
595 (length socks-password)
597 (socks-wait-for-state-change proc info state)
598 (= (gethash 'password-auth-status info) 0)))
601 ;; More advanced GSS/API stuff, not yet implemented - volunteers?
602 ;; (socks-register-authentication-method 1 "GSS/API" 'socks-gssapi-auth)
604 (defun socks-gssapi-auth (proc)
609 ;; (socks-register-authentication-method 3 "CHAP" 'socks-chap-auth)
610 (defun socks-chap-auth (proc)
615 ;; (socks-register-authentication-method 5 "CRAM" 'socks-cram-auth)
616 (defun socks-cram-auth (proc)
620 (defcustom socks-nslookup-program "nslookup"
621 "*If non-NIL then a string naming the nslookup program."
622 :type '(choice (const :tag "None" :value nil) string)
625 (defun socks-nslookup-host (host)
626 "Attempt to resolve the given HOSTNAME using nslookup if possible."
627 (interactive "sHost: ")
628 (if socks-nslookup-program
629 (let ((proc (start-process " *nslookup*" " *nslookup*"
630 socks-nslookup-program host))
632 (set-process-query-on-exit-flag proc nil)
633 (with-current-buffer (process-buffer proc)
635 (accept-process-output proc)
636 (memq (process-status proc) '(run open))))
637 (goto-char (point-min))
638 (if (re-search-forward "Name:.*\nAddress\\(es\\)?: *\\([0-9.]+\\)$" nil t)
640 (setq res (buffer-substring (match-beginning 2)
642 res (mapcar 'string-to-int (split-string res "\\.")))))
643 (kill-buffer (current-buffer)))
649 ;; arch-tag: 67aef0d9-f4f7-4056-89c3-b4c9bf93ce7f
650 ;;; socks.el ends here