1 ;;; socks.el --- A Socks v5 Client for Emacs
3 ;; Copyright (C) 1996-2000, 2002, 2007-2013 Free Software Foundation,
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 of the License, or
15 ;; (at your option) any later version.
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. If not, see <http://www.gnu.org/licenses/>.
27 ;; This is an implementation of the SOCKS v5 protocol as defined in
31 ;; - Finish the redirection rules stuff
32 ;; - Implement composition of servers. Recursively evaluate the
33 ;; redirection rules and do SOCKS-over-HTTP and SOCKS-in-SOCKS
39 ;; FIXME this is bad practice, and who is it for anyway, since Emacs
40 ;; has split-string since at least 21.1.
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 ;; FIXME this is a terrible idea.
342 ;; It is not even compatible with the argument spec of open-network-stream
343 ;; in 24.1. If this is really necessary, open-network-stream
344 ;; could get a wrapper hook, or defer to open-network-stream-function.
346 (defvar socks-override-functions nil
347 "Whether to overwrite the open-network-stream function with the SOCKSified
350 (require 'network-stream
)
352 (if (fboundp 'socks-original-open-network-stream
)
353 nil
; Do nothing, we've been here already
354 (defalias 'socks-original-open-network-stream
355 (symbol-function 'open-network-stream
))
356 (if socks-override-functions
357 (defalias 'open-network-stream
'socks-open-network-stream
)))
359 (defun socks-open-connection (server-info)
362 (let ((proc (socks-original-open-network-stream "socks"
365 (nth 2 server-info
)))
366 (info (make-hash-table :size
13))
370 ;; Initialize process and info about the process
371 (set-process-filter proc
'socks-filter
)
372 (set-process-query-on-exit-flag proc nil
)
373 (puthash proc info socks-connections
)
374 (puthash 'state socks-state-waiting-for-auth info
)
375 (puthash 'authtype socks-authentication-failure info
)
376 (puthash 'server-protocol
(nth 3 server-info
) info
)
377 (puthash 'server-name
(nth 1 server-info
) info
)
378 (setq version
(nth 3 server-info
))
380 ((equal version
'http
)
381 ;; Don't really have to do any connection setup under http
384 ;; Don't really have to do any connection setup under v4
387 ;; Need to handle all the authentication crap under v5
388 ;; Send what we think we can handle for authentication types
389 (process-send-string proc
(format "%c%s" socks-version
390 (socks-build-auth-list)))
392 ;; Basically just do a select() until we change states.
393 (socks-wait-for-state-change proc info socks-state-waiting-for-auth
)
394 (setq authtype
(gethash 'authtype info
))
396 ((= authtype socks-authentication-null
)
397 (and socks-debug
(message "No authentication necessary")))
398 ((= authtype socks-authentication-failure
)
399 (error "No acceptable authentication methods found"))
401 (let* ((auth-type (gethash 'authtype info
))
402 (auth-handler (assoc auth-type socks-authentication-methods
))
403 (auth-func (and auth-handler
(cdr (cdr auth-handler
))))
404 (auth-desc (and auth-handler
(car (cdr auth-handler
)))))
405 (set-process-filter proc nil
)
406 (if (and auth-func
(fboundp auth-func
)
407 (funcall auth-func proc
))
409 (delete-process proc
)
410 (error "Failed to use auth method: %s (%d)"
411 (or auth-desc
"Unknown") auth-type
))
415 (puthash 'state socks-state-authenticated info
)
416 (set-process-filter proc
'socks-filter
)))
419 (defun socks-send-command (proc command atype address port
)
421 ((or (= atype socks-address-type-v4
)
422 (= atype socks-address-type-v6
))
424 ((= atype socks-address-type-name
)
425 (format "%c%s" (length address
) address
))
427 (error "Unknown address type: %d" atype
))))
428 (info (gethash proc socks-connections
))
430 (or info
(error "socks-send-command called on non-SOCKS connection %S"
432 (puthash 'state socks-state-waiting info
)
433 (setq version
(gethash 'server-protocol info
))
435 ((equal version
'http
)
436 (setq request
(format (eval-when-compile
438 "CONNECT %s:%d HTTP/1.0\r\n"
439 "User-Agent: Emacs/SOCKS v1.0\r\n"
442 ((equal atype socks-address-type-name
) address
)
444 (error "Unsupported address type for HTTP: %d" atype
)))
447 (setq request
(string-make-unibyte
452 (lsh port -
8) ; port, high byte
453 (- port
(lsh (lsh port -
8) 8)) ; port, low byte
455 (user-full-name) ; username
456 0 ; terminate username
459 (setq request
(string-make-unibyte
467 (lsh port -
8) ; port, high byte
468 (- port
(lsh (lsh port -
8) 8)) ; port, low byte
471 (error "Unknown protocol version: %d" version
)))
472 (process-send-string proc request
)
473 (socks-wait-for-state-change proc info socks-state-waiting
)
474 (process-status proc
)
475 (if (= (or (gethash 'reply info
) 1) socks-response-success
)
476 nil
; Sweet sweet success!
477 (delete-process proc
)
478 (error "SOCKS: %s" (nth (or (gethash 'reply info
) 1) socks-errors
)))
482 ;; Replacement functions for open-network-stream, etc.
483 (defvar socks-noproxy nil
484 "List of regexps matching hosts that we should not socksify connections to")
486 (defun socks-find-route (host service
)
487 (let ((route socks-server
)
488 (noproxy socks-noproxy
))
490 (if (eq ?
! (aref (car noproxy
) 0))
491 (if (string-match (substring (car noproxy
) 1) host
)
493 (if (string-match (car noproxy
) host
)
496 (setq noproxy
(cdr noproxy
)))
499 (defvar socks-services-file
"/etc/services")
500 (defvar socks-tcp-services
(make-hash-table :size
13 :test
'equal
))
501 (defvar socks-udp-services
(make-hash-table :size
13 :test
'equal
))
503 (defun socks-parse-services ()
504 (if (not (and (file-exists-p socks-services-file
)
505 (file-readable-p socks-services-file
)))
506 (error "Could not find services file: %s" socks-services-file
))
507 (clrhash socks-tcp-services
)
508 (clrhash socks-udp-services
)
509 (with-current-buffer (get-buffer-create " *socks-tmp*")
511 (insert-file-contents socks-services-file
)
513 (goto-char (point-min))
514 (while (re-search-forward "#.*" nil t
)
517 (goto-char (point-min))
518 (while (re-search-forward "^[ \t\n]+" nil t
)
520 ;; Now find all the lines
521 (goto-char (point-min))
522 (let (name port type
)
523 (while (re-search-forward "^\\([^ \t]+\\)[ \t]+\\([0-9]+\\)/\\([a-z]+\\)"
525 (setq name
(downcase (match-string 1))
526 port
(string-to-number (match-string 2))
527 type
(downcase (match-string 3)))
528 (puthash name port
(if (equal type
"udp")
530 socks-tcp-services
))))))
532 (defun socks-find-services-entry (service &optional udp
)
533 "Return the port # associated with SERVICE"
534 (if (= (hash-table-count socks-tcp-services
) 0)
535 (socks-parse-services))
536 (gethash (downcase service
)
537 (if udp socks-udp-services socks-tcp-services
)))
539 (defun socks-open-network-stream (name buffer host service
)
540 (let* ((route (socks-find-route host service
))
541 proc info version atype
)
543 (socks-original-open-network-stream name buffer host service
)
544 (setq proc
(socks-open-connection route
)
545 info
(gethash proc socks-connections
)
546 version
(gethash 'server-protocol info
))
549 (setq host
(socks-nslookup-host host
))
550 (if (not (listp host
))
551 (error "Could not get IP address for: %s" host
))
552 (setq host
(apply 'format
"%c%c%c%c" host
))
553 (setq atype socks-address-type-v4
))
555 (setq atype socks-address-type-name
)))
556 (socks-send-command proc
557 socks-connect-command
560 (if (stringp service
)
562 (socks-find-services-entry service
)
563 (error "Unknown service: %s" service
))
565 (puthash 'buffer buffer info
)
566 (puthash 'host host info
)
567 (puthash 'service host info
)
568 (set-process-filter proc nil
)
569 (set-process-buffer proc
(if buffer
(get-buffer-create buffer
)))
572 ;; Authentication modules go here
574 ;; Basic username/password authentication, ala RFC 1929
575 (socks-register-authentication-method 2 "Username/Password"
576 'socks-username
/password-auth
)
578 (defconst socks-username
/password-auth-version
1)
580 (defun socks-username/password-auth-filter
(proc str
)
581 (let ((info (gethash proc socks-connections
)))
582 (or info
(error "socks-filter called on non-SOCKS connection %S" proc
))
583 (puthash 'scratch
(concat (gethash 'scratch info
) str
) info
)
584 (if (< (length (gethash 'scratch info
)) 2)
586 (puthash 'password-auth-status
(aref (gethash 'scratch info
) 1) info
)
587 (puthash 'state socks-state-authenticated info
))))
589 (defun socks-username/password-auth
(proc)
590 (let* ((info (gethash proc socks-connections
))
591 (state (gethash 'state info
)))
592 (if (not socks-password
)
593 (setq socks-password
(read-passwd
594 (format "Password for %s@%s: "
596 (gethash 'server-name info
)))))
597 (puthash 'scratch
"" info
)
598 (set-process-filter proc
'socks-username
/password-auth-filter
)
599 (process-send-string proc
601 socks-username
/password-auth-version
602 (length socks-username
)
604 (length socks-password
)
606 (socks-wait-for-state-change proc info state
)
607 (= (gethash 'password-auth-status info
) 0)))
610 ;; More advanced GSS/API stuff, not yet implemented - volunteers?
611 ;; (socks-register-authentication-method 1 "GSS/API" 'socks-gssapi-auth)
613 (defun socks-gssapi-auth (proc)
618 ;; (socks-register-authentication-method 3 "CHAP" 'socks-chap-auth)
619 (defun socks-chap-auth (proc)
624 ;; (socks-register-authentication-method 5 "CRAM" 'socks-cram-auth)
625 (defun socks-cram-auth (proc)
629 (defcustom socks-nslookup-program
"nslookup"
630 "If non-NIL then a string naming the nslookup program."
631 :type
'(choice (const :tag
"None" :value nil
) string
)
634 (defun socks-nslookup-host (host)
635 "Attempt to resolve the given HOSTNAME using nslookup if possible."
636 (interactive "sHost: ")
637 (if socks-nslookup-program
638 (let ((proc (start-process " *nslookup*" " *nslookup*"
639 socks-nslookup-program host
))
641 (set-process-query-on-exit-flag proc nil
)
642 (with-current-buffer (process-buffer proc
)
644 (accept-process-output proc
)
645 (memq (process-status proc
) '(run open
))))
646 (goto-char (point-min))
647 (if (re-search-forward "Name:.*\nAddress\\(es\\)?: *\\([0-9.]+\\)$" nil t
)
649 (setq res
(buffer-substring (match-beginning 2)
651 res
(mapcar 'string-to-int
(split-string res
"\\.")))))
652 (kill-buffer (current-buffer)))
658 ;;; socks.el ends here