2018-04-29 22:25:09 -04:00
|
|
|
|
;;; socks.el --- A Socks v5 Client for Emacs -*- lexical-binding:t -*-
|
2007-06-06 16:49:37 +00:00
|
|
|
|
|
2022-01-01 02:45:51 -05:00
|
|
|
|
;; Copyright (C) 1996-2000, 2002, 2007-2022 Free Software Foundation,
|
2013-01-01 09:11:05 +00:00
|
|
|
|
;; Inc.
|
2007-06-06 16:49:37 +00:00
|
|
|
|
|
2019-05-26 00:58:28 -07:00
|
|
|
|
;; Author: William M. Perry <wmperry@gnu.org>
|
2007-06-06 16:49:37 +00:00
|
|
|
|
;; Dave Love <fx@gnu.org>
|
|
|
|
|
|
;; Keywords: comm, firewalls
|
|
|
|
|
|
|
|
|
|
|
|
;; This file is part of GNU Emacs.
|
|
|
|
|
|
|
2008-05-06 07:31:51 +00:00
|
|
|
|
;; GNU Emacs is free software: you can redistribute it and/or modify
|
2007-06-06 16:49:37 +00:00
|
|
|
|
;; it under the terms of the GNU General Public License as published by
|
2008-05-06 07:31:51 +00:00
|
|
|
|
;; the Free Software Foundation, either version 3 of the License, or
|
|
|
|
|
|
;; (at your option) any later version.
|
2007-06-06 16:49:37 +00:00
|
|
|
|
|
|
|
|
|
|
;; GNU Emacs is distributed in the hope that it will be useful,
|
|
|
|
|
|
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
|
|
|
|
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
|
|
|
|
;; GNU General Public License for more details.
|
|
|
|
|
|
|
|
|
|
|
|
;; You should have received a copy of the GNU General Public License
|
2017-09-13 15:52:52 -07:00
|
|
|
|
;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
|
2007-06-06 16:49:37 +00:00
|
|
|
|
|
|
|
|
|
|
;;; Commentary:
|
|
|
|
|
|
|
|
|
|
|
|
;; This is an implementation of the SOCKS v5 protocol as defined in
|
|
|
|
|
|
;; RFC 1928.
|
|
|
|
|
|
|
|
|
|
|
|
;; TODO
|
|
|
|
|
|
;; - Finish the redirection rules stuff
|
|
|
|
|
|
;; - Implement composition of servers. Recursively evaluate the
|
|
|
|
|
|
;; redirection rules and do SOCKS-over-HTTP and SOCKS-in-SOCKS
|
|
|
|
|
|
|
2018-04-29 22:25:09 -04:00
|
|
|
|
;;; Code:
|
|
|
|
|
|
|
|
|
|
|
|
(eval-when-compile (require 'cl-lib))
|
|
|
|
|
|
|
|
|
|
|
|
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
|
|
;; ;;; Custom widgets
|
|
|
|
|
|
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
|
|
|
|
|
|
|
|
;; (eval-when-compile
|
|
|
|
|
|
;; (require 'wid-edit))
|
|
|
|
|
|
|
|
|
|
|
|
;; (define-widget 'dynamic-choice 'menu-choice
|
|
|
|
|
|
;; "A pretty simple dynamic dropdown list"
|
|
|
|
|
|
;; :format "%[%t%]: %v"
|
|
|
|
|
|
;; :tag "Network"
|
|
|
|
|
|
;; :case-fold t
|
|
|
|
|
|
;; :void '(item :format "invalid (%t)\n")
|
|
|
|
|
|
;; :value-create 's5-widget-value-create
|
|
|
|
|
|
;; :value-delete 'widget-children-value-delete
|
|
|
|
|
|
;; :value-get 'widget-choice-value-get
|
|
|
|
|
|
;; :value-inline 'widget-choice-value-inline
|
|
|
|
|
|
;; :mouse-down-action 'widget-choice-mouse-down-action
|
|
|
|
|
|
;; :action 'widget-choice-action
|
|
|
|
|
|
;; :error "Make a choice"
|
|
|
|
|
|
;; :validate 'widget-choice-validate
|
|
|
|
|
|
;; :match 's5-dynamic-choice-match
|
|
|
|
|
|
;; :match-inline 's5-dynamic-choice-match-inline)
|
|
|
|
|
|
;;
|
|
|
|
|
|
;; (defun s5-dynamic-choice-match (widget value)
|
|
|
|
|
|
;; (let ((choices (funcall (widget-get widget :choice-function)))
|
|
|
|
|
|
;; current found)
|
|
|
|
|
|
;; (while (and choices (not found))
|
|
|
|
|
|
;; (setq current (car choices)
|
|
|
|
|
|
;; choices (cdr choices)
|
|
|
|
|
|
;; found (widget-apply current :match value)))
|
|
|
|
|
|
;; found))
|
|
|
|
|
|
;;
|
|
|
|
|
|
;; (defun s5-dynamic-choice-match-inline (widget value)
|
|
|
|
|
|
;; (let ((choices (funcall (widget-get widget :choice-function)))
|
|
|
|
|
|
;; current found)
|
|
|
|
|
|
;; (while (and choices (not found))
|
|
|
|
|
|
;; (setq current (car choices)
|
|
|
|
|
|
;; choices (cdr choices)
|
|
|
|
|
|
;; found (widget-match-inline current value)))
|
|
|
|
|
|
;; found))
|
|
|
|
|
|
;;
|
|
|
|
|
|
;; (defun s5-widget-value-create (widget)
|
|
|
|
|
|
;; (let ((choices (funcall (widget-get widget :choice-function)))
|
|
|
|
|
|
;; (value (widget-get widget :value)))
|
|
|
|
|
|
;; (if (not value)
|
|
|
|
|
|
;; (widget-put widget :value (widget-value (car choices))))
|
|
|
|
|
|
;; (widget-put widget :args choices)
|
|
|
|
|
|
;; (widget-choice-value-create widget)))
|
2007-06-06 16:49:37 +00:00
|
|
|
|
|
|
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
|
|
;;; Customization support
|
|
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
|
|
(defgroup socks nil
|
2014-03-14 01:22:33 +01:00
|
|
|
|
"SOCKS support."
|
2008-03-01 19:16:02 +00:00
|
|
|
|
:version "22.2"
|
2007-06-06 16:49:37 +00:00
|
|
|
|
:prefix "socks-"
|
|
|
|
|
|
:group 'processes)
|
|
|
|
|
|
|
2018-04-29 22:25:09 -04:00
|
|
|
|
;; (defcustom socks-server-aliases nil
|
|
|
|
|
|
;; "A list of server aliases for use in access control and filtering rules."
|
|
|
|
|
|
;; :type '(repeat (list :format "%v"
|
|
|
|
|
|
;; :value ("" "" 1080 5)
|
|
|
|
|
|
;; (string :tag "Alias")
|
|
|
|
|
|
;; (string :tag "Hostname/IP Address")
|
|
|
|
|
|
;; (integer :tag "Port #")
|
|
|
|
|
|
;; (choice :tag "SOCKS Version"
|
|
|
|
|
|
;; (integer :tag "SOCKS v4" :value 4)
|
|
|
|
|
|
;; (integer :tag "SOCKS v5" :value 5)))))
|
|
|
|
|
|
;;
|
|
|
|
|
|
;; (defcustom socks-network-aliases
|
|
|
|
|
|
;; '(("Anywhere" (netmask "0.0.0.0" "0.0.0.0")))
|
|
|
|
|
|
;; "A list of network aliases for use in subsequent rules."
|
|
|
|
|
|
;; :type '(repeat (list :format "%v"
|
|
|
|
|
|
;; :value (netmask "" "255.255.255.0")
|
|
|
|
|
|
;; (string :tag "Alias")
|
|
|
|
|
|
;; (radio-button-choice
|
|
|
|
|
|
;; :format "%v"
|
|
|
|
|
|
;; (list :tag "IP address range"
|
|
|
|
|
|
;; (const :format "" :value range)
|
|
|
|
|
|
;; (string :tag "From")
|
|
|
|
|
|
;; (string :tag "To"))
|
|
|
|
|
|
;; (list :tag "IP address/netmask"
|
|
|
|
|
|
;; (const :format "" :value netmask)
|
|
|
|
|
|
;; (string :tag "IP Address")
|
|
|
|
|
|
;; (string :tag "Netmask"))
|
|
|
|
|
|
;; (list :tag "Domain Name"
|
|
|
|
|
|
;; (const :format "" :value domain)
|
|
|
|
|
|
;; (string :tag "Domain name"))
|
|
|
|
|
|
;; (list :tag "Unique hostname/IP address"
|
|
|
|
|
|
;; (const :format "" :value exact)
|
|
|
|
|
|
;; (string :tag "Hostname/IP Address"))))))
|
|
|
|
|
|
;;
|
|
|
|
|
|
;; (defun s5-servers-filter ()
|
|
|
|
|
|
;; (if socks-server-aliases
|
|
|
|
|
|
;; (mapcar (lambda (x) (list 'const :tag (car x) :value (car x))) s5-server-aliases)
|
|
|
|
|
|
;; '((const :tag "No aliases defined" :value nil))))
|
|
|
|
|
|
;;
|
|
|
|
|
|
;; (defun s5-network-aliases-filter ()
|
|
|
|
|
|
;; (mapcar (lambda (x) (list 'const :tag (car x) :value (car x)))
|
|
|
|
|
|
;; socks-network-aliases))
|
|
|
|
|
|
;;
|
|
|
|
|
|
;; (defcustom socks-redirection-rules
|
|
|
|
|
|
;; nil
|
|
|
|
|
|
;; "A list of redirection rules."
|
|
|
|
|
|
;; :type '(repeat (list :format "%v"
|
|
|
|
|
|
;; :value ("Anywhere" nil)
|
|
|
|
|
|
;; (dynamic-choice :choice-function s5-network-aliases-filter
|
|
|
|
|
|
;; :tag "Destination network")
|
|
|
|
|
|
;; (radio-button-choice
|
|
|
|
|
|
;; :tag "Connection type"
|
|
|
|
|
|
;; (const :tag "Direct connection" :value nil)
|
|
|
|
|
|
;; (dynamic-choice :format "%t: %[%v%]"
|
|
|
|
|
|
;; :choice-function s5-servers-filter
|
|
|
|
|
|
;; :tag "Proxy chain via")))))
|
2007-06-06 16:49:37 +00:00
|
|
|
|
|
|
|
|
|
|
(defcustom socks-server
|
|
|
|
|
|
(list "Default server" "socks" 1080 5)
|
2021-09-19 16:48:35 +02:00
|
|
|
|
"Socks server."
|
2007-06-06 16:49:37 +00:00
|
|
|
|
:type '(list
|
|
|
|
|
|
(string :format "" :value "Default server")
|
|
|
|
|
|
(string :tag "Server")
|
|
|
|
|
|
(integer :tag "Port")
|
|
|
|
|
|
(radio-button-choice :tag "SOCKS Version"
|
|
|
|
|
|
:format "%t: %v"
|
|
|
|
|
|
(const :tag "SOCKS v4 " :format "%t" :value 4)
|
|
|
|
|
|
(const :tag "SOCKS v5" :format "%t" :value 5))))
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
|
|
;;; Get down to the nitty gritty
|
|
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
|
|
(defconst socks-version 5)
|
|
|
|
|
|
(defvar socks-debug nil)
|
|
|
|
|
|
|
|
|
|
|
|
;; Common socks v5 commands
|
|
|
|
|
|
(defconst socks-connect-command 1)
|
|
|
|
|
|
(defconst socks-bind-command 2)
|
|
|
|
|
|
(defconst socks-udp-associate-command 3)
|
|
|
|
|
|
|
|
|
|
|
|
;; Miscellaneous other socks constants
|
|
|
|
|
|
(defconst socks-authentication-null 0)
|
|
|
|
|
|
(defconst socks-authentication-failure 255)
|
|
|
|
|
|
|
|
|
|
|
|
;; Response codes
|
|
|
|
|
|
(defconst socks-response-success 0)
|
|
|
|
|
|
(defconst socks-response-general-failure 1)
|
|
|
|
|
|
(defconst socks-response-access-denied 2)
|
|
|
|
|
|
(defconst socks-response-network-unreachable 3)
|
|
|
|
|
|
(defconst socks-response-host-unreachable 4)
|
|
|
|
|
|
(defconst socks-response-connection-refused 5)
|
|
|
|
|
|
(defconst socks-response-ttl-expired 6)
|
|
|
|
|
|
(defconst socks-response-cmd-not-supported 7)
|
|
|
|
|
|
(defconst socks-response-address-not-supported 8)
|
|
|
|
|
|
|
|
|
|
|
|
(defvar socks-errors
|
|
|
|
|
|
'("Succeeded"
|
|
|
|
|
|
"General SOCKS server failure"
|
|
|
|
|
|
"Connection not allowed by ruleset"
|
|
|
|
|
|
"Network unreachable"
|
|
|
|
|
|
"Host unreachable"
|
|
|
|
|
|
"Connection refused"
|
|
|
|
|
|
"Time-to-live expired"
|
|
|
|
|
|
"Command not supported"
|
|
|
|
|
|
"Address type not supported"))
|
|
|
|
|
|
|
|
|
|
|
|
;; The socks v5 address types
|
|
|
|
|
|
(defconst socks-address-type-v4 1)
|
|
|
|
|
|
(defconst socks-address-type-name 3)
|
|
|
|
|
|
(defconst socks-address-type-v6 4)
|
|
|
|
|
|
|
|
|
|
|
|
;; Base variables
|
|
|
|
|
|
(defvar socks-timeout 5)
|
|
|
|
|
|
|
|
|
|
|
|
;; Miscellaneous stuff for authentication
|
|
|
|
|
|
(defvar socks-authentication-methods nil)
|
|
|
|
|
|
(defvar socks-username (user-login-name))
|
|
|
|
|
|
(defvar socks-password nil)
|
|
|
|
|
|
|
|
|
|
|
|
(defun socks-register-authentication-method (id desc callback)
|
|
|
|
|
|
(let ((old (assq id socks-authentication-methods)))
|
|
|
|
|
|
(if old
|
|
|
|
|
|
(setcdr old (cons desc callback))
|
|
|
|
|
|
(setq socks-authentication-methods
|
|
|
|
|
|
(cons (cons id (cons desc callback))
|
|
|
|
|
|
socks-authentication-methods)))))
|
|
|
|
|
|
|
|
|
|
|
|
(defun socks-unregister-authentication-method (id)
|
|
|
|
|
|
(let ((old (assq id socks-authentication-methods)))
|
|
|
|
|
|
(if old
|
|
|
|
|
|
(setq socks-authentication-methods
|
|
|
|
|
|
(delq old socks-authentication-methods)))))
|
|
|
|
|
|
|
|
|
|
|
|
(socks-register-authentication-method 0 "No authentication" 'identity)
|
|
|
|
|
|
|
|
|
|
|
|
(defun socks-build-auth-list ()
|
|
|
|
|
|
(let ((num 0)
|
|
|
|
|
|
(retval ""))
|
2007-10-13 03:01:49 +00:00
|
|
|
|
(mapc
|
2020-11-14 17:04:23 +01:00
|
|
|
|
(lambda (x)
|
|
|
|
|
|
(if (fboundp (cdr (cdr x)))
|
|
|
|
|
|
(setq retval (format "%s%c" retval (car x))
|
|
|
|
|
|
num (1+ num))))
|
2007-06-06 16:49:37 +00:00
|
|
|
|
(reverse socks-authentication-methods))
|
|
|
|
|
|
(format "%c%s" num retval)))
|
|
|
|
|
|
|
|
|
|
|
|
(defconst socks-state-waiting-for-auth 0)
|
|
|
|
|
|
(defconst socks-state-submethod-negotiation 1)
|
|
|
|
|
|
(defconst socks-state-authenticated 2)
|
|
|
|
|
|
(defconst socks-state-waiting 3)
|
|
|
|
|
|
(defconst socks-state-connected 4)
|
|
|
|
|
|
|
2018-04-29 22:25:09 -04:00
|
|
|
|
(defun socks-wait-for-state-change (proc cur-state)
|
|
|
|
|
|
(while (and (= (process-get proc 'socks-state) cur-state)
|
|
|
|
|
|
(memq (process-status proc) '(run open)))
|
|
|
|
|
|
(accept-process-output proc socks-timeout)))
|
2007-06-06 16:49:37 +00:00
|
|
|
|
|
|
|
|
|
|
(defun socks-filter (proc string)
|
2018-04-29 22:25:09 -04:00
|
|
|
|
(let (state version desired-len)
|
|
|
|
|
|
(or (process-get proc 'socks)
|
|
|
|
|
|
(error "socks-filter called on non-SOCKS connection %S" proc))
|
|
|
|
|
|
(setq state (process-get proc 'socks-state))
|
2007-06-06 16:49:37 +00:00
|
|
|
|
(cond
|
|
|
|
|
|
((= state socks-state-waiting-for-auth)
|
2020-12-11 16:36:02 +01:00
|
|
|
|
(cl-callf (lambda (s) (setq string (concat s string)))
|
2018-04-29 22:25:09 -04:00
|
|
|
|
(process-get proc 'socks-scratch))
|
2007-06-06 16:49:37 +00:00
|
|
|
|
(if (< (length string) 2)
|
|
|
|
|
|
nil ; We need to spin some more
|
2018-04-29 22:25:09 -04:00
|
|
|
|
(process-put proc 'socks-authtype (aref string 1))
|
|
|
|
|
|
(process-put proc 'socks-scratch (substring string 2 nil))
|
|
|
|
|
|
(process-put proc 'socks-state socks-state-submethod-negotiation)))
|
2007-06-06 16:49:37 +00:00
|
|
|
|
((= state socks-state-submethod-negotiation)
|
|
|
|
|
|
)
|
|
|
|
|
|
((= state socks-state-authenticated)
|
|
|
|
|
|
)
|
|
|
|
|
|
((= state socks-state-waiting)
|
2020-12-11 16:36:02 +01:00
|
|
|
|
(cl-callf (lambda (s) (setq string (concat s string)))
|
2018-04-29 22:25:09 -04:00
|
|
|
|
(process-get proc 'socks-scratch))
|
|
|
|
|
|
(setq version (process-get proc 'socks-server-protocol))
|
2007-06-06 16:49:37 +00:00
|
|
|
|
(cond
|
|
|
|
|
|
((equal version 'http)
|
Use string-search instead of string-match[-p]
`string-search` is easier to understand, less error-prone, much
faster, does not pollute the regexp cache, and does not mutate global
state. Use it where applicable and obviously safe (erring on the
conservative side).
* admin/authors.el (authors-canonical-file-name)
(authors-scan-change-log):
* lisp/apropos.el (apropos-command)
(apropos-documentation-property, apropos-symbols-internal):
* lisp/arc-mode.el (archive-arc-summarize)
(archive-zoo-summarize):
* lisp/calc/calc-aent.el (math-read-factor):
* lisp/calc/calc-ext.el (math-read-big-expr)
(math-format-nice-expr, math-format-number-fancy):
* lisp/calc/calc-forms.el (math-read-angle-brackets):
* lisp/calc/calc-graph.el (calc-graph-set-range):
* lisp/calc/calc-keypd.el (calc-keypad-press):
* lisp/calc/calc-lang.el (tex, latex, math-read-big-rec):
* lisp/calc/calc-prog.el (calc-fix-token-name)
(calc-user-define-permanent, math-define-exp):
* lisp/calc/calc.el (calc-record, calcDigit-key)
(calc-count-lines):
* lisp/calc/calcalg2.el (calc-solve-for, calc-poly-roots)
(math-do-integral):
* lisp/calc/calcalg3.el (calc-find-root, calc-find-minimum)
(calc-get-fit-variables):
* lisp/cedet/ede/speedbar.el (ede-tag-expand):
* lisp/cedet/semantic/java.el (semantic-java-expand-tag):
* lisp/cedet/semantic/sb.el (semantic-sb-show-extra)
(semantic-sb-expand-group):
* lisp/cedet/semantic/wisent/python.el
(semantic-python-instance-variable-p):
* lisp/cus-edit.el (get):
* lisp/descr-text.el (describe-text-sexp):
* lisp/dired-aux.el (dired-compress-file):
* lisp/dired-x.el (dired-make-relative-symlink):
* lisp/dired.el (dired-glob-regexp):
* lisp/dos-fns.el (dos-convert-standard-filename, dos-8+3-filename):
* lisp/edmacro.el (edmacro-format-keys):
* lisp/emacs-lisp/eieio-opt.el (eieio-sb-expand):
* lisp/emacs-lisp/eieio-speedbar.el (eieio-speedbar-object-expand):
* lisp/emacs-lisp/lisp-mnt.el (lm-keywords-list):
* lisp/emacs-lisp/warnings.el (display-warning):
* lisp/emulation/viper-ex.el (viper-ex-read-file-name)
(ex-print-display-lines):
* lisp/env.el (read-envvar-name, setenv):
* lisp/epa-mail.el (epa-mail-encrypt):
* lisp/epg.el (epg--start):
* lisp/erc/erc-backend.el (erc-parse-server-response):
* lisp/erc/erc-dcc.el (erc-dcc-member):
* lisp/erc/erc-speedbar.el (erc-speedbar-expand-server)
(erc-speedbar-expand-channel, erc-speedbar-expand-user):
* lisp/erc/erc.el (erc-send-input):
* lisp/eshell/em-glob.el (eshell-glob-entries):
* lisp/eshell/esh-proc.el (eshell-needs-pipe-p):
* lisp/eshell/esh-util.el (eshell-convert):
* lisp/eshell/esh-var.el (eshell-envvar-names):
* lisp/faces.el (x-resolve-font-name):
* lisp/ffap.el (ffap-file-at-point):
* lisp/files.el (wildcard-to-regexp, shell-quote-wildcard-pattern):
* lisp/forms.el (forms--update):
* lisp/frameset.el (frameset-filter-unshelve-param):
* lisp/gnus/gnus-art.el (article-decode-charset):
* lisp/gnus/gnus-kill.el (gnus-kill-parse-rn-kill-file):
* lisp/gnus/gnus-mlspl.el (gnus-group-split-fancy):
* lisp/gnus/gnus-msg.el (gnus-summary-resend-message-insert-gcc)
(gnus-inews-insert-gcc):
* lisp/gnus/gnus-rfc1843.el (rfc1843-decode-article-body):
* lisp/gnus/gnus-search.el (gnus-search-indexed-parse-output)
(gnus-search--complete-key-data):
* lisp/gnus/gnus-spec.el (gnus-parse-simple-format):
* lisp/gnus/gnus-sum.el (gnus-summary-refer-article):
* lisp/gnus/gnus-util.el (gnus-extract-address-components)
(gnus-newsgroup-directory-form):
* lisp/gnus/gnus-uu.el (gnus-uu-grab-view):
* lisp/gnus/gnus.el (gnus-group-native-p, gnus-short-group-name):
* lisp/gnus/message.el (message-check-news-header-syntax)
(message-make-message-id, message-user-mail-address)
(message-make-fqdn, message-get-reply-headers, message-followup):
* lisp/gnus/mm-decode.el (mm-dissect-buffer):
* lisp/gnus/nnheader.el (nnheader-insert):
* lisp/gnus/nnimap.el (nnimap-process-quirk)
(nnimap-imap-ranges-to-gnus-ranges):
* lisp/gnus/nnmaildir.el (nnmaildir--ensure-suffix):
* lisp/gnus/nnmairix.el (nnmairix-determine-original-group-from-path):
* lisp/gnus/nnrss.el (nnrss-match-macro):
* lisp/gnus/nntp.el (nntp-find-group-and-number):
* lisp/help-fns.el (help--symbol-completion-table-affixation):
* lisp/help.el (help-function-arglist):
* lisp/hippie-exp.el (he-concat-directory-file-name):
* lisp/htmlfontify.el (hfy-relstub):
* lisp/ido.el (ido-make-prompt, ido-complete, ido-copy-current-word)
(ido-exhibit):
* lisp/image/image-converter.el (image-convert-p):
* lisp/info-xref.el (info-xref-docstrings):
* lisp/info.el (Info-toc-build, Info-follow-reference)
(Info-backward-node, Info-finder-find-node)
(Info-speedbar-expand-node):
* lisp/international/mule-diag.el (print-fontset-element):
* lisp/language/korea-util.el (default-korean-keyboard):
* lisp/linum.el (linum-after-change):
* lisp/mail/ietf-drums.el (ietf-drums-parse-address):
* lisp/mail/mail-utils.el (mail-dont-reply-to):
* lisp/mail/rfc2047.el (rfc2047-encode-1, rfc2047-decode-string):
* lisp/mail/rfc2231.el (rfc2231-parse-string):
* lisp/mail/rmailkwd.el (rmail-set-label):
* lisp/mail/rmailsum.el (rmail-header-summary):
* lisp/mail/smtpmail.el (smtpmail-maybe-append-domain)
(smtpmail-user-mail-address):
* lisp/mail/uce.el (uce-reply-to-uce):
* lisp/man.el (Man-default-man-entry):
* lisp/mh-e/mh-alias.el (mh-alias-gecos-name)
(mh-alias-minibuffer-confirm-address):
* lisp/mh-e/mh-comp.el (mh-forwarded-letter-subject):
* lisp/mh-e/mh-speed.el (mh-speed-parse-flists-output):
* lisp/mh-e/mh-utils.el (mh-collect-folder-names-filter)
(mh-folder-completion-function):
* lisp/minibuffer.el (completion--make-envvar-table)
(completion-file-name-table, completion-flex-try-completion)
(completion-flex-all-completions):
* lisp/mpc.el (mpc--proc-quote-string, mpc-cmd-special-tag-p)
(mpc-constraints-tag-lookup):
* lisp/net/ange-ftp.el (ange-ftp-send-cmd)
(ange-ftp-allow-child-lookup):
* lisp/net/mailcap.el (mailcap-mime-types):
* lisp/net/mairix.el (mairix-search-thread-this-article):
* lisp/net/pop3.el (pop3-open-server):
* lisp/net/soap-client.el (soap-decode-xs-complex-type):
* lisp/net/socks.el (socks-filter):
* lisp/nxml/nxml-outln.el (nxml-highlighted-qname):
* lisp/nxml/rng-cmpct.el (rng-c-expand-name, rng-c-expand-datatype):
* lisp/nxml/rng-uri.el (rng-uri-file-name-1):
* lisp/obsolete/complete.el (partial-completion-mode)
(PC-do-completion):
* lisp/obsolete/longlines.el (longlines-encode-string):
* lisp/obsolete/nnir.el (nnir-compose-result):
* lisp/obsolete/terminal.el (te-quote-arg-for-sh):
* lisp/obsolete/tpu-edt.el (tpu-check-search-case):
* lisp/obsolete/url-ns.el (isPlainHostName):
* lisp/pcmpl-unix.el (pcomplete/scp):
* lisp/play/dunnet.el (dun-listify-string2, dun-get-path)
(dun-unix-parse, dun-doassign, dun-cat, dun-batch-unix-interface):
* lisp/progmodes/ebnf2ps.el: (ebnf-eps-header-footer-comment):
* lisp/progmodes/gdb-mi.el (gdb-var-delete)
(gdb-speedbar-expand-node, gdbmi-bnf-incomplete-record-result):
* lisp/progmodes/gud.el (gud-find-expr):
* lisp/progmodes/idlw-help.el (idlwave-do-context-help1):
* lisp/progmodes/idlw-shell.el (idlwave-shell-mode)
(idlwave-shell-filter-hidden-output, idlwave-shell-filter):
* lisp/progmodes/idlwave.el (idlwave-skip-label-or-case)
(idlwave-routine-info):
* lisp/progmodes/octave.el (inferior-octave-completion-at-point):
* lisp/progmodes/sh-script.el (sh-add-completer):
* lisp/progmodes/sql.el (defun):
* lisp/progmodes/xscheme.el (xscheme-process-filter):
* lisp/replace.el (query-replace-compile-replacement)
(map-query-replace-regexp):
* lisp/shell.el (shell--command-completion-data)
(shell-environment-variable-completion):
* lisp/simple.el (display-message-or-buffer):
* lisp/speedbar.el (speedbar-dired, speedbar-tag-file)
(speedbar-tag-expand):
* lisp/subr.el (split-string-and-unquote):
* lisp/tar-mode.el (tar-extract):
* lisp/term.el (term-command-hook, serial-read-name):
* lisp/textmodes/bibtex.el (bibtex-print-help-message):
* lisp/textmodes/ispell.el (ispell-lookup-words, ispell-filter)
(ispell-parse-output, ispell-buffer-local-parsing):
* lisp/textmodes/reftex-cite.el (reftex-do-citation):
* lisp/textmodes/reftex-parse.el (reftex-notice-new):
* lisp/textmodes/reftex-ref.el (reftex-show-entry):
* lisp/textmodes/reftex.el (reftex-compile-variables):
* lisp/textmodes/tex-mode.el (tex-send-command)
(tex-start-tex, tex-append):
* lisp/thingatpt.el (thing-at-point-url-at-point):
* lisp/tmm.el (tmm-add-one-shortcut):
* lisp/transient.el (transient-format-key):
* lisp/url/url-auth.el (url-basic-auth)
(url-digest-auth-directory-id-assoc):
* lisp/url/url-news.el (url-news):
* lisp/url/url-util.el (url-parse-query-string):
* lisp/vc/vc-cvs.el (vc-cvs-parse-entry):
* lisp/wid-browse.el (widget-browse-sexp):
* lisp/woman.el (woman-parse-colon-path, woman-mini-help)
(WoMan-getpage-in-background, woman-negative-vertical-space):
* lisp/xml.el:
* test/lisp/emacs-lisp/check-declare-tests.el
(check-declare-tests-warn):
* test/lisp/files-tests.el
(files-tests-file-name-non-special-dired-compress-handler):
* test/lisp/net/network-stream-tests.el (server-process-filter):
* test/src/coding-tests.el (ert-test-unibyte-buffer-dos-eol-decode):
Use `string-search` instead of `string-match` and `string-match-p`.
2021-08-09 11:20:00 +02:00
|
|
|
|
(if (not (string-search "\r\n\r\n" string))
|
2007-06-06 16:49:37 +00:00
|
|
|
|
nil ; Need to spin some more
|
2018-04-29 22:25:09 -04:00
|
|
|
|
(process-put proc 'socks-state socks-state-connected)
|
|
|
|
|
|
(process-put proc 'socks-reply 0)
|
|
|
|
|
|
(process-put proc 'socks-response string)))
|
2007-06-06 16:49:37 +00:00
|
|
|
|
((equal version 4)
|
|
|
|
|
|
(if (< (length string) 2)
|
|
|
|
|
|
nil ; Can't know how much to read yet
|
|
|
|
|
|
(setq desired-len
|
|
|
|
|
|
(+ 4 ; address length
|
|
|
|
|
|
2 ; port
|
|
|
|
|
|
2 ; initial data
|
|
|
|
|
|
))
|
|
|
|
|
|
(if (< (length string) desired-len)
|
|
|
|
|
|
nil ; need to spin some more
|
|
|
|
|
|
(let ((response (aref string 1)))
|
|
|
|
|
|
(if (= response 90)
|
|
|
|
|
|
(setq response 0))
|
2018-04-29 22:25:09 -04:00
|
|
|
|
(process-put proc 'socks-state socks-state-connected)
|
|
|
|
|
|
(process-put proc 'socks-reply response)
|
|
|
|
|
|
(process-put proc 'socks-response string)))))
|
2007-06-06 16:49:37 +00:00
|
|
|
|
((equal version 5)
|
|
|
|
|
|
(if (< (length string) 4)
|
|
|
|
|
|
nil
|
|
|
|
|
|
(setq desired-len
|
|
|
|
|
|
(+ 6 ; Standard socks header
|
2018-04-29 22:25:09 -04:00
|
|
|
|
(pcase (aref string 3)
|
|
|
|
|
|
((pred (= socks-address-type-v4)) 4)
|
|
|
|
|
|
((pred (= socks-address-type-v6)) 16)
|
|
|
|
|
|
((pred (= socks-address-type-name))
|
|
|
|
|
|
(if (< (length string) 5)
|
|
|
|
|
|
255
|
|
|
|
|
|
(+ 1 (aref string 4)))))))
|
2007-06-06 16:49:37 +00:00
|
|
|
|
(if (< (length string) desired-len)
|
|
|
|
|
|
nil ; Need to spin some more
|
2018-04-29 22:25:09 -04:00
|
|
|
|
(process-put proc 'socks-state socks-state-connected)
|
|
|
|
|
|
(process-put proc 'socks-reply (aref string 1))
|
|
|
|
|
|
(process-put proc 'socks-response string))))))
|
|
|
|
|
|
((= state socks-state-connected)))))
|
2007-11-28 04:04:21 +00:00
|
|
|
|
|
2012-02-17 00:19:12 -08:00
|
|
|
|
;; FIXME this is a terrible idea.
|
|
|
|
|
|
;; It is not even compatible with the argument spec of open-network-stream
|
2018-04-29 22:25:09 -04:00
|
|
|
|
;; in 24.1.
|
2012-02-17 00:19:12 -08:00
|
|
|
|
|
2007-11-28 04:04:21 +00:00
|
|
|
|
(defvar socks-override-functions nil
|
2018-04-29 22:25:09 -04:00
|
|
|
|
"If non-nil, overwrite `open-network-stream' function with SOCKSified version.")
|
2012-02-17 00:19:12 -08:00
|
|
|
|
|
2018-04-29 22:25:09 -04:00
|
|
|
|
(when socks-override-functions
|
|
|
|
|
|
(advice-add 'open-network-stream :around #'socks--open-network-stream))
|
2007-11-28 04:04:21 +00:00
|
|
|
|
|
2007-06-06 16:49:37 +00:00
|
|
|
|
(defun socks-open-connection (server-info)
|
|
|
|
|
|
(interactive)
|
|
|
|
|
|
(save-excursion
|
2018-04-29 22:25:09 -04:00
|
|
|
|
(let ((proc
|
|
|
|
|
|
(let ((socks-override-functions nil))
|
|
|
|
|
|
(open-network-stream "socks"
|
|
|
|
|
|
nil
|
|
|
|
|
|
(nth 1 server-info)
|
|
|
|
|
|
(nth 2 server-info))))
|
2007-06-06 16:49:37 +00:00
|
|
|
|
(authtype nil)
|
|
|
|
|
|
version)
|
|
|
|
|
|
|
|
|
|
|
|
;; Initialize process and info about the process
|
2018-04-29 22:25:09 -04:00
|
|
|
|
(set-process-filter proc #'socks-filter)
|
2007-06-06 16:49:37 +00:00
|
|
|
|
(set-process-query-on-exit-flag proc nil)
|
2018-04-29 22:25:09 -04:00
|
|
|
|
(process-put proc 'socks t)
|
|
|
|
|
|
(process-put proc 'socks-state socks-state-waiting-for-auth)
|
|
|
|
|
|
(process-put proc 'socks-authtype socks-authentication-failure)
|
|
|
|
|
|
(process-put proc 'socks-server-protocol (nth 3 server-info))
|
|
|
|
|
|
(process-put proc 'socks-server-name (nth 1 server-info))
|
2007-06-06 16:49:37 +00:00
|
|
|
|
(setq version (nth 3 server-info))
|
|
|
|
|
|
(cond
|
|
|
|
|
|
((equal version 'http)
|
|
|
|
|
|
;; Don't really have to do any connection setup under http
|
|
|
|
|
|
nil)
|
|
|
|
|
|
((equal version 4)
|
|
|
|
|
|
;; Don't really have to do any connection setup under v4
|
|
|
|
|
|
nil)
|
|
|
|
|
|
((equal version 5)
|
|
|
|
|
|
;; Need to handle all the authentication crap under v5
|
|
|
|
|
|
;; Send what we think we can handle for authentication types
|
|
|
|
|
|
(process-send-string proc (format "%c%s" socks-version
|
|
|
|
|
|
(socks-build-auth-list)))
|
|
|
|
|
|
|
|
|
|
|
|
;; Basically just do a select() until we change states.
|
2018-04-29 22:25:09 -04:00
|
|
|
|
(socks-wait-for-state-change proc socks-state-waiting-for-auth)
|
|
|
|
|
|
(setq authtype (process-get proc 'socks-authtype))
|
2007-06-06 16:49:37 +00:00
|
|
|
|
(cond
|
|
|
|
|
|
((= authtype socks-authentication-null)
|
|
|
|
|
|
(and socks-debug (message "No authentication necessary")))
|
|
|
|
|
|
((= authtype socks-authentication-failure)
|
2009-09-24 01:37:14 +00:00
|
|
|
|
(error "No acceptable authentication methods found"))
|
2007-06-06 16:49:37 +00:00
|
|
|
|
(t
|
2018-04-29 22:25:09 -04:00
|
|
|
|
(let* ((auth-type (process-get proc 'socks-authtype))
|
2007-06-06 16:49:37 +00:00
|
|
|
|
(auth-handler (assoc auth-type socks-authentication-methods))
|
|
|
|
|
|
(auth-func (and auth-handler (cdr (cdr auth-handler))))
|
|
|
|
|
|
(auth-desc (and auth-handler (car (cdr auth-handler)))))
|
|
|
|
|
|
(set-process-filter proc nil)
|
|
|
|
|
|
(if (and auth-func (fboundp auth-func)
|
|
|
|
|
|
(funcall auth-func proc))
|
|
|
|
|
|
nil ; We succeeded!
|
|
|
|
|
|
(delete-process proc)
|
|
|
|
|
|
(error "Failed to use auth method: %s (%d)"
|
|
|
|
|
|
(or auth-desc "Unknown") auth-type))
|
|
|
|
|
|
)
|
|
|
|
|
|
)
|
|
|
|
|
|
)
|
2018-04-29 22:25:09 -04:00
|
|
|
|
(process-put proc 'socks-state socks-state-authenticated)
|
2021-01-07 13:43:13 +01:00
|
|
|
|
(process-put proc 'socks-scratch "")
|
2018-04-29 22:25:09 -04:00
|
|
|
|
(set-process-filter proc #'socks-filter)))
|
2007-06-06 16:49:37 +00:00
|
|
|
|
proc)))
|
|
|
|
|
|
|
|
|
|
|
|
(defun socks-send-command (proc command atype address port)
|
2021-02-05 19:41:04 -08:00
|
|
|
|
"Send COMMAND to SOCKS service PROC for proxying ADDRESS and PORT.
|
|
|
|
|
|
When ATYPE indicates an IP, param ADDRESS must be given as raw bytes."
|
2007-06-06 16:49:37 +00:00
|
|
|
|
(let ((addr (cond
|
|
|
|
|
|
((or (= atype socks-address-type-v4)
|
|
|
|
|
|
(= atype socks-address-type-v6))
|
|
|
|
|
|
address)
|
|
|
|
|
|
((= atype socks-address-type-name)
|
|
|
|
|
|
(format "%c%s" (length address) address))
|
|
|
|
|
|
(t
|
2011-12-30 17:27:15 -08:00
|
|
|
|
(error "Unknown address type: %d" atype))))
|
2007-06-06 16:49:37 +00:00
|
|
|
|
request version)
|
2018-04-29 22:25:09 -04:00
|
|
|
|
(or (process-get proc 'socks)
|
|
|
|
|
|
(error "socks-send-command called on non-SOCKS connection %S" proc))
|
|
|
|
|
|
(process-put proc 'socks-state socks-state-waiting)
|
|
|
|
|
|
(setq version (process-get proc 'socks-server-protocol))
|
2007-06-06 16:49:37 +00:00
|
|
|
|
(cond
|
|
|
|
|
|
((equal version 'http)
|
|
|
|
|
|
(setq request (format (eval-when-compile
|
|
|
|
|
|
(concat
|
|
|
|
|
|
"CONNECT %s:%d HTTP/1.0\r\n"
|
|
|
|
|
|
"User-Agent: Emacs/SOCKS v1.0\r\n"
|
|
|
|
|
|
"\r\n"))
|
|
|
|
|
|
(cond
|
|
|
|
|
|
((equal atype socks-address-type-name) address)
|
|
|
|
|
|
(t
|
|
|
|
|
|
(error "Unsupported address type for HTTP: %d" atype)))
|
|
|
|
|
|
port)))
|
|
|
|
|
|
((equal version 4)
|
2018-04-29 22:25:09 -04:00
|
|
|
|
(setq request (concat
|
|
|
|
|
|
(unibyte-string
|
|
|
|
|
|
version ; version
|
|
|
|
|
|
command ; command
|
Audit use of lsh and fix glitches
I audited use of lsh in the Lisp source code, and fixed the
glitches that I found. While I was at it, I replaced uses of lsh
with ash when either will do. Replacement is OK when either
argument is known to be nonnegative, or when only the low-order
bits of the result matter, and is a (minor) win since ash is a bit
more solid than lsh nowadays, and is a bit faster.
* lisp/calc/calc-ext.el (math-check-fixnum):
Prefer most-positive-fixnum to (lsh -1 -1).
* lisp/vc/vc-hg.el (vc-hg-state-fast): When testing fixnum width,
prefer (zerop (ash most-positive-fixnum -32)) to (zerop (lsh -1
32)) (Bug#32485#11).
* lisp/emacs-lisp/bytecomp.el (byte-compile-lapcode):
Tighten sanity-check for bytecode overflow, by checking that the
result of (ash pc -8) is nonnegative. Formerly this check was not
needed since lsh was used and the number overflowed differently.
* lisp/net/dns.el (dns-write): Fix some obvious sign typos in
shift counts. Evidently this part of the code has never been
exercised.
* lisp/progmodes/hideif.el (hif-shiftleft, hif-shiftright):
* lisp/term/common-win.el (x-setup-function-keys):
Simplify.
* admin/unidata/unidata-gen.el, admin/unidata/uvs.el:
* doc/lispref/keymaps.texi, doc/lispref/syntax.texi:
* doc/misc/calc.texi, doc/misc/cl.texi, etc/NEWS.19:
* lisp/arc-mode.el, lisp/calc/calc-bin.el, lisp/calc/calc-comb.el:
* lisp/calc/calc-ext.el, lisp/calc/calc-math.el:
* lisp/cedet/semantic/wisent/comp.el, lisp/composite.el:
* lisp/disp-table.el, lisp/dos-fns.el, lisp/edmacro.el:
* lisp/emacs-lisp/bindat.el, lisp/emacs-lisp/byte-opt.el:
* lisp/emacs-lisp/bytecomp.el, lisp/emacs-lisp/cl-extra.el:
* lisp/erc/erc-dcc.el, lisp/facemenu.el, lisp/gnus/message.el:
* lisp/gnus/nndoc.el, lisp/gnus/nnmaildir.el, lisp/image.el:
* lisp/international/ccl.el, lisp/international/fontset.el:
* lisp/international/mule-cmds.el, lisp/international/mule.el:
* lisp/json.el, lisp/mail/binhex.el, lisp/mail/rmail.el:
* lisp/mail/uudecode.el, lisp/md4.el, lisp/net/dns.el:
* lisp/net/ntlm.el, lisp/net/sasl.el, lisp/net/socks.el:
* lisp/net/tramp.el, lisp/obsolete/levents.el:
* lisp/obsolete/pgg-parse.el, lisp/org/org.el:
* lisp/org/ox-publish.el, lisp/progmodes/cc-defs.el:
* lisp/progmodes/ebnf2ps.el, lisp/progmodes/hideif.el:
* lisp/ps-bdf.el, lisp/ps-print.el, lisp/simple.el:
* lisp/tar-mode.el, lisp/term/common-win.el:
* lisp/term/tty-colors.el, lisp/term/xterm.el, lisp/vc/vc-git.el:
* lisp/vc/vc-hg.el, lisp/x-dnd.el, test/src/data-tests.el:
Prefer ash to lsh when either will do.
2018-08-21 13:44:03 -07:00
|
|
|
|
(ash port -8) ; port, high byte
|
2018-04-29 22:25:09 -04:00
|
|
|
|
(logand port #xff)) ; port, low byte
|
|
|
|
|
|
addr ; address
|
|
|
|
|
|
(user-full-name) ; username
|
|
|
|
|
|
"\0"))) ; terminate username
|
2007-06-06 16:49:37 +00:00
|
|
|
|
((equal version 5)
|
2018-04-29 22:25:09 -04:00
|
|
|
|
(setq request (concat
|
|
|
|
|
|
(unibyte-string
|
2009-11-27 07:35:14 +00:00
|
|
|
|
version ; version
|
|
|
|
|
|
command ; command
|
|
|
|
|
|
0 ; reserved
|
2018-04-29 22:25:09 -04:00
|
|
|
|
atype) ; address type
|
|
|
|
|
|
addr ; address
|
|
|
|
|
|
(unibyte-string
|
Audit use of lsh and fix glitches
I audited use of lsh in the Lisp source code, and fixed the
glitches that I found. While I was at it, I replaced uses of lsh
with ash when either will do. Replacement is OK when either
argument is known to be nonnegative, or when only the low-order
bits of the result matter, and is a (minor) win since ash is a bit
more solid than lsh nowadays, and is a bit faster.
* lisp/calc/calc-ext.el (math-check-fixnum):
Prefer most-positive-fixnum to (lsh -1 -1).
* lisp/vc/vc-hg.el (vc-hg-state-fast): When testing fixnum width,
prefer (zerop (ash most-positive-fixnum -32)) to (zerop (lsh -1
32)) (Bug#32485#11).
* lisp/emacs-lisp/bytecomp.el (byte-compile-lapcode):
Tighten sanity-check for bytecode overflow, by checking that the
result of (ash pc -8) is nonnegative. Formerly this check was not
needed since lsh was used and the number overflowed differently.
* lisp/net/dns.el (dns-write): Fix some obvious sign typos in
shift counts. Evidently this part of the code has never been
exercised.
* lisp/progmodes/hideif.el (hif-shiftleft, hif-shiftright):
* lisp/term/common-win.el (x-setup-function-keys):
Simplify.
* admin/unidata/unidata-gen.el, admin/unidata/uvs.el:
* doc/lispref/keymaps.texi, doc/lispref/syntax.texi:
* doc/misc/calc.texi, doc/misc/cl.texi, etc/NEWS.19:
* lisp/arc-mode.el, lisp/calc/calc-bin.el, lisp/calc/calc-comb.el:
* lisp/calc/calc-ext.el, lisp/calc/calc-math.el:
* lisp/cedet/semantic/wisent/comp.el, lisp/composite.el:
* lisp/disp-table.el, lisp/dos-fns.el, lisp/edmacro.el:
* lisp/emacs-lisp/bindat.el, lisp/emacs-lisp/byte-opt.el:
* lisp/emacs-lisp/bytecomp.el, lisp/emacs-lisp/cl-extra.el:
* lisp/erc/erc-dcc.el, lisp/facemenu.el, lisp/gnus/message.el:
* lisp/gnus/nndoc.el, lisp/gnus/nnmaildir.el, lisp/image.el:
* lisp/international/ccl.el, lisp/international/fontset.el:
* lisp/international/mule-cmds.el, lisp/international/mule.el:
* lisp/json.el, lisp/mail/binhex.el, lisp/mail/rmail.el:
* lisp/mail/uudecode.el, lisp/md4.el, lisp/net/dns.el:
* lisp/net/ntlm.el, lisp/net/sasl.el, lisp/net/socks.el:
* lisp/net/tramp.el, lisp/obsolete/levents.el:
* lisp/obsolete/pgg-parse.el, lisp/org/org.el:
* lisp/org/ox-publish.el, lisp/progmodes/cc-defs.el:
* lisp/progmodes/ebnf2ps.el, lisp/progmodes/hideif.el:
* lisp/ps-bdf.el, lisp/ps-print.el, lisp/simple.el:
* lisp/tar-mode.el, lisp/term/common-win.el:
* lisp/term/tty-colors.el, lisp/term/xterm.el, lisp/vc/vc-git.el:
* lisp/vc/vc-hg.el, lisp/x-dnd.el, test/src/data-tests.el:
Prefer ash to lsh when either will do.
2018-08-21 13:44:03 -07:00
|
|
|
|
(ash port -8) ; port, high byte
|
2018-04-29 22:25:09 -04:00
|
|
|
|
(logand port #xff))))) ; port, low byte
|
2007-06-06 16:49:37 +00:00
|
|
|
|
(t
|
|
|
|
|
|
(error "Unknown protocol version: %d" version)))
|
|
|
|
|
|
(process-send-string proc request)
|
2018-04-29 22:25:09 -04:00
|
|
|
|
(socks-wait-for-state-change proc socks-state-waiting)
|
2007-06-06 16:49:37 +00:00
|
|
|
|
(process-status proc)
|
2018-04-29 22:25:09 -04:00
|
|
|
|
(if (= (or (process-get proc 'socks-reply) 1) socks-response-success)
|
2007-06-06 16:49:37 +00:00
|
|
|
|
nil ; Sweet sweet success!
|
|
|
|
|
|
(delete-process proc)
|
2018-04-29 22:25:09 -04:00
|
|
|
|
(error "SOCKS: %s"
|
|
|
|
|
|
(nth (or (process-get proc 'socks-reply) 1) socks-errors)))
|
2007-06-06 16:49:37 +00:00
|
|
|
|
proc))
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
;; Replacement functions for open-network-stream, etc.
|
|
|
|
|
|
(defvar socks-noproxy nil
|
2021-09-14 08:43:18 +02:00
|
|
|
|
"List of regexps matching hosts that we should not socksify connections to.")
|
2007-06-06 16:49:37 +00:00
|
|
|
|
|
2018-04-29 22:25:09 -04:00
|
|
|
|
(defun socks-find-route (host _service)
|
2007-06-06 16:49:37 +00:00
|
|
|
|
(let ((route socks-server)
|
|
|
|
|
|
(noproxy socks-noproxy))
|
|
|
|
|
|
(while noproxy
|
|
|
|
|
|
(if (eq ?! (aref (car noproxy) 0))
|
|
|
|
|
|
(if (string-match (substring (car noproxy) 1) host)
|
|
|
|
|
|
(setq noproxy nil))
|
|
|
|
|
|
(if (string-match (car noproxy) host)
|
|
|
|
|
|
(setq route nil
|
|
|
|
|
|
noproxy nil)))
|
|
|
|
|
|
(setq noproxy (cdr noproxy)))
|
|
|
|
|
|
route))
|
|
|
|
|
|
|
|
|
|
|
|
(defvar socks-services-file "/etc/services")
|
|
|
|
|
|
(defvar socks-tcp-services (make-hash-table :size 13 :test 'equal))
|
|
|
|
|
|
(defvar socks-udp-services (make-hash-table :size 13 :test 'equal))
|
|
|
|
|
|
|
|
|
|
|
|
(defun socks-parse-services ()
|
|
|
|
|
|
(if (not (and (file-exists-p socks-services-file)
|
|
|
|
|
|
(file-readable-p socks-services-file)))
|
|
|
|
|
|
(error "Could not find services file: %s" socks-services-file))
|
2007-08-23 18:36:07 +00:00
|
|
|
|
(clrhash socks-tcp-services)
|
|
|
|
|
|
(clrhash socks-udp-services)
|
|
|
|
|
|
(with-current-buffer (get-buffer-create " *socks-tmp*")
|
2007-06-06 16:49:37 +00:00
|
|
|
|
(erase-buffer)
|
|
|
|
|
|
(insert-file-contents socks-services-file)
|
|
|
|
|
|
;; Nuke comments
|
|
|
|
|
|
(goto-char (point-min))
|
|
|
|
|
|
(while (re-search-forward "#.*" nil t)
|
|
|
|
|
|
(replace-match ""))
|
|
|
|
|
|
;; Nuke empty lines
|
|
|
|
|
|
(goto-char (point-min))
|
|
|
|
|
|
(while (re-search-forward "^[ \t\n]+" nil t)
|
|
|
|
|
|
(replace-match ""))
|
|
|
|
|
|
;; Now find all the lines
|
|
|
|
|
|
(goto-char (point-min))
|
|
|
|
|
|
(let (name port type)
|
|
|
|
|
|
(while (re-search-forward "^\\([^ \t]+\\)[ \t]+\\([0-9]+\\)/\\([a-z]+\\)"
|
|
|
|
|
|
nil t)
|
|
|
|
|
|
(setq name (downcase (match-string 1))
|
|
|
|
|
|
port (string-to-number (match-string 2))
|
|
|
|
|
|
type (downcase (match-string 3)))
|
|
|
|
|
|
(puthash name port (if (equal type "udp")
|
|
|
|
|
|
socks-udp-services
|
|
|
|
|
|
socks-tcp-services))))))
|
|
|
|
|
|
|
|
|
|
|
|
(defun socks-find-services-entry (service &optional udp)
|
2014-03-14 01:22:33 +01:00
|
|
|
|
"Return the port # associated with SERVICE."
|
2007-06-06 16:49:37 +00:00
|
|
|
|
(if (= (hash-table-count socks-tcp-services) 0)
|
|
|
|
|
|
(socks-parse-services))
|
|
|
|
|
|
(gethash (downcase service)
|
|
|
|
|
|
(if udp socks-udp-services socks-tcp-services)))
|
|
|
|
|
|
|
|
|
|
|
|
(defun socks-open-network-stream (name buffer host service)
|
2018-04-29 22:25:09 -04:00
|
|
|
|
(let ((socks-override-functions t))
|
|
|
|
|
|
(socks--open-network-stream
|
|
|
|
|
|
(lambda (&rest args)
|
|
|
|
|
|
(let ((socks-override-functions nil))
|
|
|
|
|
|
(apply #'open-network-stream args)))
|
|
|
|
|
|
name buffer host service)))
|
|
|
|
|
|
|
|
|
|
|
|
(defun socks--open-network-stream (orig-fun name buffer host service &rest params)
|
|
|
|
|
|
(let ((route (and socks-override-functions
|
|
|
|
|
|
(socks-find-route host service))))
|
2007-06-06 16:49:37 +00:00
|
|
|
|
(if (not route)
|
2018-04-29 22:25:09 -04:00
|
|
|
|
(apply orig-fun name buffer host service params)
|
|
|
|
|
|
;; FIXME: Obey `params'!
|
|
|
|
|
|
(let* ((proc (socks-open-connection route))
|
|
|
|
|
|
(version (process-get proc 'socks-server-protocol))
|
|
|
|
|
|
(atype
|
|
|
|
|
|
(cond
|
|
|
|
|
|
((equal version 4)
|
|
|
|
|
|
(setq host (socks-nslookup-host host))
|
|
|
|
|
|
(if (not (listp host))
|
|
|
|
|
|
(error "Could not get IP address for: %s" host))
|
2021-02-05 19:41:04 -08:00
|
|
|
|
(setq host (apply #'unibyte-string host))
|
2018-04-29 22:25:09 -04:00
|
|
|
|
socks-address-type-v4)
|
|
|
|
|
|
(t
|
|
|
|
|
|
socks-address-type-name))))
|
|
|
|
|
|
(socks-send-command proc
|
|
|
|
|
|
socks-connect-command
|
|
|
|
|
|
atype
|
|
|
|
|
|
host
|
|
|
|
|
|
(if (stringp service)
|
|
|
|
|
|
(or
|
|
|
|
|
|
(socks-find-services-entry service)
|
|
|
|
|
|
(error "Unknown service: %s" service))
|
|
|
|
|
|
service))
|
|
|
|
|
|
(process-put proc 'socks-buffer buffer)
|
|
|
|
|
|
(process-put proc 'socks-host host)
|
2020-12-11 16:36:02 +01:00
|
|
|
|
(process-put proc 'socks-service service)
|
2018-04-29 22:25:09 -04:00
|
|
|
|
(set-process-filter proc nil)
|
|
|
|
|
|
(set-process-buffer proc (if buffer (get-buffer-create buffer)))
|
|
|
|
|
|
proc))))
|
2007-06-06 16:49:37 +00:00
|
|
|
|
|
|
|
|
|
|
;; Authentication modules go here
|
|
|
|
|
|
|
|
|
|
|
|
;; Basic username/password authentication, ala RFC 1929
|
|
|
|
|
|
(socks-register-authentication-method 2 "Username/Password"
|
|
|
|
|
|
'socks-username/password-auth)
|
|
|
|
|
|
|
|
|
|
|
|
(defconst socks-username/password-auth-version 1)
|
|
|
|
|
|
|
|
|
|
|
|
(defun socks-username/password-auth-filter (proc str)
|
2018-04-29 22:25:09 -04:00
|
|
|
|
(or (process-get proc 'socks)
|
|
|
|
|
|
(error "socks-filter called on non-SOCKS connection %S" proc))
|
|
|
|
|
|
(cl-callf (lambda (s) (concat s str))
|
|
|
|
|
|
(process-get proc 'socks-scratch))
|
|
|
|
|
|
(if (< (length (process-get proc 'socks-scratch)) 2)
|
|
|
|
|
|
nil
|
|
|
|
|
|
(process-put proc 'socks-password-auth-status
|
|
|
|
|
|
(aref (process-get proc 'socks-scratch) 1))
|
|
|
|
|
|
(process-put proc 'socks-state socks-state-authenticated)))
|
2007-06-06 16:49:37 +00:00
|
|
|
|
|
|
|
|
|
|
(defun socks-username/password-auth (proc)
|
2018-04-29 22:25:09 -04:00
|
|
|
|
(let ((state (process-get proc 'socks-state)))
|
2007-06-06 16:49:37 +00:00
|
|
|
|
(if (not socks-password)
|
|
|
|
|
|
(setq socks-password (read-passwd
|
|
|
|
|
|
(format "Password for %s@%s: "
|
|
|
|
|
|
socks-username
|
2018-04-29 22:25:09 -04:00
|
|
|
|
(process-get proc 'socks-server-name)))))
|
|
|
|
|
|
(process-put proc 'socks-scratch "")
|
|
|
|
|
|
(set-process-filter proc #'socks-username/password-auth-filter)
|
2007-06-06 16:49:37 +00:00
|
|
|
|
(process-send-string proc
|
|
|
|
|
|
(format "%c%c%s%c%s"
|
|
|
|
|
|
socks-username/password-auth-version
|
|
|
|
|
|
(length socks-username)
|
|
|
|
|
|
socks-username
|
|
|
|
|
|
(length socks-password)
|
|
|
|
|
|
socks-password))
|
2018-04-29 22:25:09 -04:00
|
|
|
|
(socks-wait-for-state-change proc state)
|
|
|
|
|
|
(= (process-get proc 'socks-password-auth-status) 0)))
|
2007-06-06 16:49:37 +00:00
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
;; More advanced GSS/API stuff, not yet implemented - volunteers?
|
|
|
|
|
|
;; (socks-register-authentication-method 1 "GSS/API" 'socks-gssapi-auth)
|
|
|
|
|
|
|
2018-04-29 22:25:09 -04:00
|
|
|
|
(defun socks-gssapi-auth (_proc)
|
2007-06-06 16:49:37 +00:00
|
|
|
|
nil)
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
;; CHAP stuff
|
|
|
|
|
|
;; (socks-register-authentication-method 3 "CHAP" 'socks-chap-auth)
|
2018-04-29 22:25:09 -04:00
|
|
|
|
(defun socks-chap-auth (_proc)
|
2007-06-06 16:49:37 +00:00
|
|
|
|
nil)
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
;; CRAM stuff
|
|
|
|
|
|
;; (socks-register-authentication-method 5 "CRAM" 'socks-cram-auth)
|
2018-04-29 22:25:09 -04:00
|
|
|
|
(defun socks-cram-auth (_proc)
|
2007-06-06 16:49:37 +00:00
|
|
|
|
nil)
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
(defcustom socks-nslookup-program "nslookup"
|
2018-04-29 22:25:09 -04:00
|
|
|
|
"If non-nil then a string naming the nslookup program."
|
|
|
|
|
|
:type '(choice (const :tag "None" :value nil) string))
|
2007-06-06 16:49:37 +00:00
|
|
|
|
|
|
|
|
|
|
(defun socks-nslookup-host (host)
|
|
|
|
|
|
"Attempt to resolve the given HOSTNAME using nslookup if possible."
|
|
|
|
|
|
(interactive "sHost: ")
|
|
|
|
|
|
(if socks-nslookup-program
|
|
|
|
|
|
(let ((proc (start-process " *nslookup*" " *nslookup*"
|
|
|
|
|
|
socks-nslookup-program host))
|
|
|
|
|
|
(res host))
|
|
|
|
|
|
(set-process-query-on-exit-flag proc nil)
|
2007-08-23 18:36:07 +00:00
|
|
|
|
(with-current-buffer (process-buffer proc)
|
2007-06-06 16:49:37 +00:00
|
|
|
|
(while (progn
|
|
|
|
|
|
(accept-process-output proc)
|
|
|
|
|
|
(memq (process-status proc) '(run open))))
|
|
|
|
|
|
(goto-char (point-min))
|
|
|
|
|
|
(if (re-search-forward "Name:.*\nAddress\\(es\\)?: *\\([0-9.]+\\)$" nil t)
|
|
|
|
|
|
(progn
|
|
|
|
|
|
(setq res (buffer-substring (match-beginning 2)
|
|
|
|
|
|
(match-end 2))
|
2018-04-29 22:25:09 -04:00
|
|
|
|
res (mapcar #'string-to-number
|
2018-04-24 21:13:00 -04:00
|
|
|
|
(split-string res "\\.")))))
|
2007-06-06 16:49:37 +00:00
|
|
|
|
(kill-buffer (current-buffer)))
|
|
|
|
|
|
res)
|
|
|
|
|
|
host))
|
|
|
|
|
|
|
|
|
|
|
|
(provide 'socks)
|
|
|
|
|
|
|
|
|
|
|
|
;;; socks.el ends here
|