1 ;;; socks.el --- A Socks v5 Client for Emacs
3 ;; Copyright (C) 1996-2000, 2002, 2007-2015 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
41 (defalias 'socks-split-string 'split-string) ; since at least 21.1
42 (if (fboundp 'split-string)
43 (defalias 'socks-split-string 'split-string)
44 (defun socks-split-string (string &optional pattern)
45 "Return a list of substrings of STRING which are separated by PATTERN.
46 If PATTERN is omitted, it defaults to \"[ \\f\\t\\n\\r\\v]+\"."
48 (setq pattern "[ \f\t\n\r\v]+"))
49 (let (parts (start 0))
50 (while (string-match pattern string start)
51 (setq parts (cons (substring string start
52 (match-beginning 0)) parts)
54 (nreverse (cons (substring string start) parts)))))))
55 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
57 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
58 ;;; (define-widget 'dynamic-choice 'menu-choice
59 ;;; "A pretty simple dynamic dropdown list"
60 ;;; :format "%[%t%]: %v"
63 ;;; :void '(item :format "invalid (%t)\n")
64 ;;; :value-create 's5-widget-value-create
65 ;;; :value-delete 'widget-children-value-delete
66 ;;; :value-get 'widget-choice-value-get
67 ;;; :value-inline 'widget-choice-value-inline
68 ;;; :mouse-down-action 'widget-choice-mouse-down-action
69 ;;; :action 'widget-choice-action
70 ;;; :error "Make a choice"
71 ;;; :validate 'widget-choice-validate
72 ;;; :match 's5-dynamic-choice-match
73 ;;; :match-inline 's5-dynamic-choice-match-inline)
75 ;;; (defun s5-dynamic-choice-match (widget value)
76 ;;; (let ((choices (funcall (widget-get widget :choice-function)))
78 ;;; (while (and choices (not found))
79 ;;; (setq current (car choices)
80 ;;; choices (cdr choices)
81 ;;; found (widget-apply current :match value)))
84 ;;; (defun s5-dynamic-choice-match-inline (widget value)
85 ;;; (let ((choices (funcall (widget-get widget :choice-function)))
87 ;;; (while (and choices (not found))
88 ;;; (setq current (car choices)
89 ;;; choices (cdr choices)
90 ;;; found (widget-match-inline current value)))
93 ;;; (defun s5-widget-value-create (widget)
94 ;;; (let ((choices (funcall (widget-get widget :choice-function)))
95 ;;; (value (widget-get widget :value)))
97 ;;; (widget-put widget :value (widget-value (car choices))))
98 ;;; (widget-put widget :args choices)
99 ;;; (widget-choice-value-create widget)))
101 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
102 ;;; Customization support
103 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
110 ;;; (defcustom socks-server-aliases nil
111 ;;; "A list of server aliases for use in access control and filtering rules."
113 ;;; :type '(repeat (list :format "%v"
114 ;;; :value ("" "" 1080 5)
115 ;;; (string :tag "Alias")
116 ;;; (string :tag "Hostname/IP Address")
117 ;;; (integer :tag "Port #")
118 ;;; (choice :tag "SOCKS Version"
119 ;;; (integer :tag "SOCKS v4" :value 4)
120 ;;; (integer :tag "SOCKS v5" :value 5)))))
122 ;;; (defcustom socks-network-aliases
123 ;;; '(("Anywhere" (netmask "0.0.0.0" "0.0.0.0")))
124 ;;; "A list of network aliases for use in subsequent rules."
126 ;;; :type '(repeat (list :format "%v"
127 ;;; :value (netmask "" "255.255.255.0")
128 ;;; (string :tag "Alias")
129 ;;; (radio-button-choice
131 ;;; (list :tag "IP address range"
132 ;;; (const :format "" :value range)
133 ;;; (string :tag "From")
134 ;;; (string :tag "To"))
135 ;;; (list :tag "IP address/netmask"
136 ;;; (const :format "" :value netmask)
137 ;;; (string :tag "IP Address")
138 ;;; (string :tag "Netmask"))
139 ;;; (list :tag "Domain Name"
140 ;;; (const :format "" :value domain)
141 ;;; (string :tag "Domain name"))
142 ;;; (list :tag "Unique hostname/IP address"
143 ;;; (const :format "" :value exact)
144 ;;; (string :tag "Hostname/IP Address"))))))
146 ;;; (defun s5-servers-filter ()
147 ;;; (if socks-server-aliases
148 ;;; (mapcar (lambda (x) (list 'const :tag (car x) :value (car x))) s5-server-aliases)
149 ;;; '((const :tag "No aliases defined" :value nil))))
151 ;;; (defun s5-network-aliases-filter ()
152 ;;; (mapcar (lambda (x) (list 'const :tag (car x) :value (car x)))
153 ;;; socks-network-aliases))
155 ;;; (defcustom socks-redirection-rules
157 ;;; "A list of redirection rules."
159 ;;; :type '(repeat (list :format "%v"
160 ;;; :value ("Anywhere" nil)
161 ;;; (dynamic-choice :choice-function s5-network-aliases-filter
162 ;;; :tag "Destination network")
163 ;;; (radio-button-choice
164 ;;; :tag "Connection type"
165 ;;; (const :tag "Direct connection" :value nil)
166 ;;; (dynamic-choice :format "%t: %[%v%]"
167 ;;; :choice-function s5-servers-filter
168 ;;; :tag "Proxy chain via")))))
170 (defcustom socks-server
171 (list "Default server" "socks" 1080 5)
175 (string :format "" :value "Default server")
176 (string :tag "Server")
177 (integer :tag "Port")
178 (radio-button-choice :tag "SOCKS Version"
180 (const :tag "SOCKS v4 " :format "%t" :value 4)
181 (const :tag "SOCKS v5" :format "%t" :value 5))))
184 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
185 ;;; Get down to the nitty gritty
186 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
187 (defconst socks-version 5)
188 (defvar socks-debug nil)
190 ;; Common socks v5 commands
191 (defconst socks-connect-command 1)
192 (defconst socks-bind-command 2)
193 (defconst socks-udp-associate-command 3)
195 ;; Miscellaneous other socks constants
196 (defconst socks-authentication-null 0)
197 (defconst socks-authentication-failure 255)
200 (defconst socks-response-success 0)
201 (defconst socks-response-general-failure 1)
202 (defconst socks-response-access-denied 2)
203 (defconst socks-response-network-unreachable 3)
204 (defconst socks-response-host-unreachable 4)
205 (defconst socks-response-connection-refused 5)
206 (defconst socks-response-ttl-expired 6)
207 (defconst socks-response-cmd-not-supported 7)
208 (defconst socks-response-address-not-supported 8)
212 "General SOCKS server failure"
213 "Connection not allowed by ruleset"
214 "Network unreachable"
217 "Time-to-live expired"
218 "Command not supported"
219 "Address type not supported"))
221 ;; The socks v5 address types
222 (defconst socks-address-type-v4 1)
223 (defconst socks-address-type-name 3)
224 (defconst socks-address-type-v6 4)
227 (defvar socks-timeout 5)
228 (defvar socks-connections (make-hash-table :size 13))
230 ;; Miscellaneous stuff for authentication
231 (defvar socks-authentication-methods nil)
232 (defvar socks-username (user-login-name))
233 (defvar socks-password nil)
235 (defun socks-register-authentication-method (id desc callback)
236 (let ((old (assq id socks-authentication-methods)))
238 (setcdr old (cons desc callback))
239 (setq socks-authentication-methods
240 (cons (cons id (cons desc callback))
241 socks-authentication-methods)))))
243 (defun socks-unregister-authentication-method (id)
244 (let ((old (assq id socks-authentication-methods)))
246 (setq socks-authentication-methods
247 (delq old socks-authentication-methods)))))
249 (socks-register-authentication-method 0 "No authentication" 'identity)
251 (defun socks-build-auth-list ()
257 (if (fboundp (cdr (cdr x)))
258 (setq retval (format "%s%c" retval (car x))
260 (reverse socks-authentication-methods))
261 (format "%c%s" num retval)))
263 (defconst socks-state-waiting-for-auth 0)
264 (defconst socks-state-submethod-negotiation 1)
265 (defconst socks-state-authenticated 2)
266 (defconst socks-state-waiting 3)
267 (defconst socks-state-connected 4)
269 (defmacro socks-wait-for-state-change (proc htable cur-state)
270 `(while (and (= (gethash 'state ,htable) ,cur-state)
271 (memq (process-status ,proc) '(run open)))
272 (accept-process-output ,proc socks-timeout)))
274 (defun socks-filter (proc string)
275 (let ((info (gethash proc socks-connections))
276 state version desired-len)
277 (or info (error "socks-filter called on non-SOCKS connection %S" proc))
278 (setq state (gethash 'state info))
280 ((= state socks-state-waiting-for-auth)
281 (puthash 'scratch (concat string (gethash 'scratch info)) info)
282 (setq string (gethash 'scratch info))
283 (if (< (length string) 2)
284 nil ; We need to spin some more
285 (puthash 'authtype (aref string 1) info)
286 (puthash 'scratch (substring string 2 nil) info)
287 (puthash 'state socks-state-submethod-negotiation info)))
288 ((= state socks-state-submethod-negotiation)
290 ((= state socks-state-authenticated)
292 ((= state socks-state-waiting)
293 (puthash 'scratch (concat string (gethash 'scratch info)) info)
294 (setq string (gethash 'scratch info))
295 (setq version (gethash 'server-protocol info))
297 ((equal version 'http)
298 (if (not (string-match "\r\n\r\n" string))
299 nil ; Need to spin some more
300 (puthash 'state socks-state-connected info)
301 (puthash 'reply 0 info)
302 (puthash 'response string info)))
304 (if (< (length string) 2)
305 nil ; Can't know how much to read yet
307 (+ 4 ; address length
311 (if (< (length string) desired-len)
312 nil ; need to spin some more
313 (let ((response (aref string 1)))
316 (puthash 'state socks-state-connected info)
317 (puthash 'reply response info)
318 (puthash 'response string info)))))
320 (if (< (length string) 4)
323 (+ 6 ; Standard socks header
325 ((= (aref string 3) socks-address-type-v4) 4)
326 ((= (aref string 3) socks-address-type-v6) 16)
327 ((= (aref string 3) socks-address-type-name)
328 (if (< (length string) 5)
330 (+ 1 (aref string 4)))))))
331 (if (< (length string) desired-len)
332 nil ; Need to spin some more
333 (puthash 'state socks-state-connected info)
334 (puthash 'reply (aref string 1) info)
335 (puthash 'response string info))))))
336 ((= state socks-state-connected)
342 (declare-function socks-original-open-network-stream "socks") ; fset
344 ;; FIXME this is a terrible idea.
345 ;; It is not even compatible with the argument spec of open-network-stream
346 ;; in 24.1. If this is really necessary, open-network-stream
347 ;; could get a wrapper hook, or defer to open-network-stream-function.
349 (defvar socks-override-functions nil
350 "Whether to overwrite the `open-network-stream' function with the SOCKSified
353 (require 'network-stream)
355 (if (fboundp 'socks-original-open-network-stream)
356 nil ; Do nothing, we've been here already
357 (defalias 'socks-original-open-network-stream
358 (symbol-function 'open-network-stream))
359 (if socks-override-functions
360 (defalias 'open-network-stream 'socks-open-network-stream)))
362 (defun socks-open-connection (server-info)
365 (let ((proc (socks-original-open-network-stream "socks"
368 (nth 2 server-info)))
369 (info (make-hash-table :size 13))
373 ;; Initialize process and info about the process
374 (set-process-filter proc 'socks-filter)
375 (set-process-query-on-exit-flag proc nil)
376 (puthash proc info socks-connections)
377 (puthash 'state socks-state-waiting-for-auth info)
378 (puthash 'authtype socks-authentication-failure info)
379 (puthash 'server-protocol (nth 3 server-info) info)
380 (puthash 'server-name (nth 1 server-info) info)
381 (setq version (nth 3 server-info))
383 ((equal version 'http)
384 ;; Don't really have to do any connection setup under http
387 ;; Don't really have to do any connection setup under v4
390 ;; Need to handle all the authentication crap under v5
391 ;; Send what we think we can handle for authentication types
392 (process-send-string proc (format "%c%s" socks-version
393 (socks-build-auth-list)))
395 ;; Basically just do a select() until we change states.
396 (socks-wait-for-state-change proc info socks-state-waiting-for-auth)
397 (setq authtype (gethash 'authtype info))
399 ((= authtype socks-authentication-null)
400 (and socks-debug (message "No authentication necessary")))
401 ((= authtype socks-authentication-failure)
402 (error "No acceptable authentication methods found"))
404 (let* ((auth-type (gethash 'authtype info))
405 (auth-handler (assoc auth-type socks-authentication-methods))
406 (auth-func (and auth-handler (cdr (cdr auth-handler))))
407 (auth-desc (and auth-handler (car (cdr auth-handler)))))
408 (set-process-filter proc nil)
409 (if (and auth-func (fboundp auth-func)
410 (funcall auth-func proc))
412 (delete-process proc)
413 (error "Failed to use auth method: %s (%d)"
414 (or auth-desc "Unknown") auth-type))
418 (puthash 'state socks-state-authenticated info)
419 (set-process-filter proc 'socks-filter)))
422 (defun socks-send-command (proc command atype address port)
424 ((or (= atype socks-address-type-v4)
425 (= atype socks-address-type-v6))
427 ((= atype socks-address-type-name)
428 (format "%c%s" (length address) address))
430 (error "Unknown address type: %d" atype))))
431 (info (gethash proc socks-connections))
433 (or info (error "socks-send-command called on non-SOCKS connection %S"
435 (puthash 'state socks-state-waiting info)
436 (setq version (gethash 'server-protocol info))
438 ((equal version 'http)
439 (setq request (format (eval-when-compile
441 "CONNECT %s:%d HTTP/1.0\r\n"
442 "User-Agent: Emacs/SOCKS v1.0\r\n"
445 ((equal atype socks-address-type-name) address)
447 (error "Unsupported address type for HTTP: %d" atype)))
450 (setq request (string-make-unibyte
455 (lsh port -8) ; port, high byte
456 (- port (lsh (lsh port -8) 8)) ; port, low byte
458 (user-full-name) ; username
459 0 ; terminate username
462 (setq request (string-make-unibyte
470 (lsh port -8) ; port, high byte
471 (- port (lsh (lsh port -8) 8)) ; port, low byte
474 (error "Unknown protocol version: %d" version)))
475 (process-send-string proc request)
476 (socks-wait-for-state-change proc info socks-state-waiting)
477 (process-status proc)
478 (if (= (or (gethash 'reply info) 1) socks-response-success)
479 nil ; Sweet sweet success!
480 (delete-process proc)
481 (error "SOCKS: %s" (nth (or (gethash 'reply info) 1) socks-errors)))
485 ;; Replacement functions for open-network-stream, etc.
486 (defvar socks-noproxy nil
487 "List of regexps matching hosts that we should not socksify connections to")
489 (defun socks-find-route (host service)
490 (let ((route socks-server)
491 (noproxy socks-noproxy))
493 (if (eq ?! (aref (car noproxy) 0))
494 (if (string-match (substring (car noproxy) 1) host)
496 (if (string-match (car noproxy) host)
499 (setq noproxy (cdr noproxy)))
502 (defvar socks-services-file "/etc/services")
503 (defvar socks-tcp-services (make-hash-table :size 13 :test 'equal))
504 (defvar socks-udp-services (make-hash-table :size 13 :test 'equal))
506 (defun socks-parse-services ()
507 (if (not (and (file-exists-p socks-services-file)
508 (file-readable-p socks-services-file)))
509 (error "Could not find services file: %s" socks-services-file))
510 (clrhash socks-tcp-services)
511 (clrhash socks-udp-services)
512 (with-current-buffer (get-buffer-create " *socks-tmp*")
514 (insert-file-contents socks-services-file)
516 (goto-char (point-min))
517 (while (re-search-forward "#.*" nil t)
520 (goto-char (point-min))
521 (while (re-search-forward "^[ \t\n]+" nil t)
523 ;; Now find all the lines
524 (goto-char (point-min))
525 (let (name port type)
526 (while (re-search-forward "^\\([^ \t]+\\)[ \t]+\\([0-9]+\\)/\\([a-z]+\\)"
528 (setq name (downcase (match-string 1))
529 port (string-to-number (match-string 2))
530 type (downcase (match-string 3)))
531 (puthash name port (if (equal type "udp")
533 socks-tcp-services))))))
535 (defun socks-find-services-entry (service &optional udp)
536 "Return the port # associated with SERVICE."
537 (if (= (hash-table-count socks-tcp-services) 0)
538 (socks-parse-services))
539 (gethash (downcase service)
540 (if udp socks-udp-services socks-tcp-services)))
542 (defun socks-open-network-stream (name buffer host service)
543 (let* ((route (socks-find-route host service))
544 proc info version atype)
546 (socks-original-open-network-stream name buffer host service)
547 (setq proc (socks-open-connection route)
548 info (gethash proc socks-connections)
549 version (gethash 'server-protocol info))
552 (setq host (socks-nslookup-host host))
553 (if (not (listp host))
554 (error "Could not get IP address for: %s" host))
555 (setq host (apply 'format "%c%c%c%c" host))
556 (setq atype socks-address-type-v4))
558 (setq atype socks-address-type-name)))
559 (socks-send-command proc
560 socks-connect-command
563 (if (stringp service)
565 (socks-find-services-entry service)
566 (error "Unknown service: %s" service))
568 (puthash 'buffer buffer info)
569 (puthash 'host host info)
570 (puthash 'service host info)
571 (set-process-filter proc nil)
572 (set-process-buffer proc (if buffer (get-buffer-create buffer)))
575 ;; Authentication modules go here
577 ;; Basic username/password authentication, ala RFC 1929
578 (socks-register-authentication-method 2 "Username/Password"
579 'socks-username/password-auth)
581 (defconst socks-username/password-auth-version 1)
583 (defun socks-username/password-auth-filter (proc str)
584 (let ((info (gethash proc socks-connections)))
585 (or info (error "socks-filter called on non-SOCKS connection %S" proc))
586 (puthash 'scratch (concat (gethash 'scratch info) str) info)
587 (if (< (length (gethash 'scratch info)) 2)
589 (puthash 'password-auth-status (aref (gethash 'scratch info) 1) info)
590 (puthash 'state socks-state-authenticated info))))
592 (defun socks-username/password-auth (proc)
593 (let* ((info (gethash proc socks-connections))
594 (state (gethash 'state info)))
595 (if (not socks-password)
596 (setq socks-password (read-passwd
597 (format "Password for %s@%s: "
599 (gethash 'server-name info)))))
600 (puthash 'scratch "" info)
601 (set-process-filter proc 'socks-username/password-auth-filter)
602 (process-send-string proc
604 socks-username/password-auth-version
605 (length socks-username)
607 (length socks-password)
609 (socks-wait-for-state-change proc info state)
610 (= (gethash 'password-auth-status info) 0)))
613 ;; More advanced GSS/API stuff, not yet implemented - volunteers?
614 ;; (socks-register-authentication-method 1 "GSS/API" 'socks-gssapi-auth)
616 (defun socks-gssapi-auth (proc)
621 ;; (socks-register-authentication-method 3 "CHAP" 'socks-chap-auth)
622 (defun socks-chap-auth (proc)
627 ;; (socks-register-authentication-method 5 "CRAM" 'socks-cram-auth)
628 (defun socks-cram-auth (proc)
632 (defcustom socks-nslookup-program "nslookup"
633 "If non-NIL then a string naming the nslookup program."
634 :type '(choice (const :tag "None" :value nil) string)
637 (defun socks-nslookup-host (host)
638 "Attempt to resolve the given HOSTNAME using nslookup if possible."
639 (interactive "sHost: ")
640 (if socks-nslookup-program
641 (let ((proc (start-process " *nslookup*" " *nslookup*"
642 socks-nslookup-program host))
644 (set-process-query-on-exit-flag proc nil)
645 (with-current-buffer (process-buffer proc)
647 (accept-process-output proc)
648 (memq (process-status proc) '(run open))))
649 (goto-char (point-min))
650 (if (re-search-forward "Name:.*\nAddress\\(es\\)?: *\\([0-9.]+\\)$" nil t)
652 (setq res (buffer-substring (match-beginning 2)
654 res (mapcar 'string-to-number
655 (socks-split-string res "\\.")))))
656 (kill-buffer (current-buffer)))
662 ;;; socks.el ends here