cgit.sxemacs.org Git - packages/blob - xemacs-packages/w3/lisp/socks.el

   1 ;;; socks.el --- A Socks v5 Client for Emacs
   2 ;; Author: wmperry
   3 ;; Created: 1999/11/09 14:52:16
   4 ;; Version: 1.4
   5 ;; Keywords: comm, firewalls
   6
   7 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   8 ;;; Copyright (c) 1996 - 1998 by William M. Perry <wmperry@cs.indiana.edu>
   9 ;;; Copyright (c) 1996 - 1999 Free Software Foundation, Inc.
  10 ;;;
  11 ;;; This file is part of GNU Emacs.
  12 ;;;
  13 ;;; GNU Emacs is free software; you can redistribute it and/or modify
  14 ;;; it under the terms of the GNU General Public License as published by
  15 ;;; the Free Software Foundation; either version 2, or (at your option)
  16 ;;; any later version.
  17 ;;;
  18 ;;; GNU Emacs is distributed in the hope that it will be useful,
  19 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  20 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  21 ;;; GNU General Public License for more details.
  22 ;;;
  23 ;;; You should have received a copy of the GNU General Public License
  24 ;;; along with GNU Emacs; see the file COPYING.  If not, write to
  25 ;;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  26 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  27 ;;;
  28 ;;; This is an implementation of the SOCKS v5 protocol as defined in
  29 ;;; RFC 1928.
  30 ;;;
  31 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  32
  33 ;; TODO
  34 ;; - Finish the redirection rules stuff
  35 ;; - Implement composition of servers.  Recursively evaluate the
  36 ;;   redirection rules and do SOCKS-over-HTTP and SOCKS-in-SOCKS
  37
  38 (require 'cl)
  39 (require 'custom)
  40
  41 ;; For non-MULE
  42 (if (not (fboundp 'char-int))
  43     (fset 'char-int 'identity))
  44
  45 (if (not (fboundp 'split-string))
  46     (defun split-string (string &optional pattern)
  47       "Return a list of substrings of STRING which are separated by PATTERN.
  48 If PATTERN is omitted, it defaults to \"[ \\f\\t\\n\\r\\v]+\"."
  49       (or pattern
  50           (setq pattern "[ \f\t\n\r\v]+"))
  51       (let (parts (start 0))
  52         (while (string-match pattern string start)
  53           (setq parts (cons (substring string start (match-beginning 0)) parts)
  54                 start (match-end 0)))
  55         (nreverse (cons (substring string start) parts)))))
  56 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  57 ;;; Custom widgets
  58 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  59 (define-widget 'dynamic-choice 'menu-choice
  60   "A pretty simple dynamic dropdown list"
  61   :format "%[%t%]: %v"
  62   :tag "Network"
  63   :case-fold t
  64   :void '(item :format "invalid (%t)\n")
  65   :value-create 's5-widget-value-create
  66   :value-delete 'widget-children-value-delete
  67   :value-get 'widget-choice-value-get
  68   :value-inline 'widget-choice-value-inline
  69   :mouse-down-action 'widget-choice-mouse-down-action
  70   :action 'widget-choice-action
  71   :error "Make a choice"
  72   :validate 'widget-choice-validate
  73   :match 's5-dynamic-choice-match
  74   :match-inline 's5-dynamic-choice-match-inline)
  75
  76 (defun s5-dynamic-choice-match (widget value)
  77   (let ((choices (funcall (widget-get widget :choice-function)))
  78         current found)
  79     (while (and choices (not found))
  80       (setq current (car choices)
  81             choices (cdr choices)
  82             found (widget-apply current :match value)))
  83     found))
  84
  85 (defun s5-dynamic-choice-match-inline (widget value)
  86   (let ((choices (funcall (widget-get widget :choice-function)))
  87         current found)
  88     (while (and choices (not found))
  89       (setq current (car choices)
  90             choices (cdr choices)
  91             found (widget-match-inline current value)))
  92     found))
  93
  94 (defun s5-widget-value-create (widget)
  95   (let ((choices (funcall (widget-get widget :choice-function)))
  96         (value (widget-get widget :value)))
  97     (if (not value)
  98         (widget-put widget :value (widget-value (car choices))))
  99     (widget-put widget :args choices)
 100     (widget-choice-value-create widget)))
 101
 102 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 103 ;;; Customization support
 104 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 105 (defgroup socks nil
 106   "SOCKS Support"
 107   :prefix "socks-"
 108   :group 'processes)
 109
 110 '(defcustom socks-server-aliases nil
 111   "A list of server aliases for use in access control and filtering rules."
 112   :group 'socks
 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)))))
 121
 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."
 125   :group 'socks
 126   :type '(repeat (list :format "%v"
 127                        :value (netmask "" "255.255.255.0")
 128                        (string :tag "Alias")
 129                        (radio-button-choice
 130                         :format "%v"
 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"))))))
 145
 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))))
 150
 151 '(defun s5-network-aliases-filter ()
 152   (mapcar (lambda (x) (list 'const :tag (car x) :value (car x)))
 153           socks-network-aliases))
 154
 155 '(defcustom socks-redirection-rules
 156    nil
 157    "A list of redirection rules."
 158    :group 'socks
 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")))))
 169
 170 (defcustom socks-server
 171   (list "Default server" "socks" 1080 5)
 172   ""
 173   :group 'socks
 174   :type '(list
 175           (string :format "" :value "Default server")
 176           (string :tag "Server")
 177           (integer :tag "Port")
 178           (radio-button-choice :tag "SOCKS Version"
 179                                :format "%t: %v"
 180                                (const :tag "SOCKS v4  " :format "%t" :value 4)
 181                                (const :tag "SOCKS v5"   :format "%t" :value 5))))
 182
 183
 184 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 185 ;;; Get down to the nitty gritty
 186 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 187 (defconst socks-version 5)
 188 (defvar socks-debug nil)
 189
 190 ;; Common socks v5 commands
 191 (defconst socks-connect-command 1)
 192 (defconst socks-bind-command 2)
 193 (defconst socks-udp-associate-command 3)
 194
 195 ;; Miscellaneous other socks constants
 196 (defconst socks-authentication-null 0)
 197 (defconst socks-authentication-failure 255)
 198
 199 ;; Response codes
 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)
 209
 210 (defvar socks-errors
 211   '("Succeeded"
 212     "General SOCKS server failure"
 213     "Connection not allowed by ruleset"
 214     "Network unreachable"
 215     "Host unreachable"
 216     "Connection refused"
 217     "Time-to-live expired"
 218     "Command not supported"
 219     "Address type not supported"))
 220
 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)
 225
 226 ;; Base variables
 227 (defvar socks-timeout 5)
 228 (defvar socks-connections (make-hash-table :size 13))
 229
 230 ;; Miscellaneous stuff for authentication
 231 (defvar socks-authentication-methods nil)
 232 (defvar socks-username (user-login-name))
 233 (defvar socks-password nil)
 234
 235 (defun socks-register-authentication-method (id desc callback)
 236   (let ((old (assq id socks-authentication-methods)))
 237     (if old
 238         (setcdr old (cons desc callback))
 239       (setq socks-authentication-methods
 240             (cons (cons id (cons desc callback))
 241                   socks-authentication-methods)))))
 242
 243 (defun socks-unregister-authentication-method (id)
 244   (let ((old (assq id socks-authentication-methods)))
 245     (if old
 246         (setq socks-authentication-methods
 247               (delq old socks-authentication-methods)))))
 248
 249 (socks-register-authentication-method 0 "No authentication" 'identity)
 250
 251 (defun socks-build-auth-list ()
 252   (let ((num 0)
 253         (retval ""))
 254     (mapc
 255      (function
 256       (lambda (x)
 257         (if (fboundp (cdr (cdr x)))
 258             (setq retval (format "%s%c" retval (car x))
 259                   num (1+ num)))))
 260      (reverse socks-authentication-methods))
 261     (format "%c%s" num retval)))
 262
 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)
 268
 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)))
 273
 274 (defun socks-filter (proc string)
 275   (let ((info (gethash proc socks-connections))
 276         state desired-len)
 277     (or info (error "socks-filter called on non-SOCKS connection %S" proc))
 278     (setq state (gethash 'state info))
 279     (cond
 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 (char-int (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)
 289       )
 290      ((= state socks-state-authenticated)
 291       )
 292      ((= state socks-state-waiting)
 293       (puthash 'scratch (concat string (gethash 'scratch info)) info)
 294       (setq string (gethash 'scratch info))
 295       (case (gethash 'server-protocol info)
 296         (http
 297          (if (not (string-match "\r\n\r\n" string))
 298              nil                        ; Need to spin some more
 299            (debug)
 300            (puthash 'state socks-state-connected info)
 301            (puthash 'reply 0 info)
 302            (puthash 'response string info)))
 303         (4
 304          (if (< (length string) 2)
 305              nil                        ; Can't know how much to read yet
 306            (setq desired-len
 307                  (+ 4 ; address length
 308                     2 ; port
 309                     2 ; initial data
 310                     ))
 311            (if (< (length string) desired-len)
 312                nil                      ; need to spin some more
 313              (let ((response (char-int (aref string 1))))
 314                (if (= response 90)
 315                    (setq response 0))
 316                (puthash 'state socks-state-connected info)
 317                (puthash 'reply response info)
 318                (puthash 'response string info)))))
 319         (5
 320          (if (< (length string) 4)
 321              nil
 322            (setq desired-len
 323                  (+ 6                   ; Standard socks header
 324                     (cond
 325                      ((= (char-int (aref string 3)) socks-address-type-v4) 4)
 326                      ((= (char-int (aref string 3)) socks-address-type-v6) 16)
 327                      ((= (char-int (aref string 3)) socks-address-type-name)
 328                       (if (< (length string) 5)
 329                           255
 330                         (+ 1 (char-int (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 (char-int (aref string 1)) info)
 335              (puthash 'response string info))))))
 336      ((= state socks-state-connected)
 337       )
 338      )
 339     )
 340   )
 341
 342 (defun socks-open-connection (server-info)
 343   (interactive)
 344   (save-excursion
 345     (let ((proc (socks-original-open-network-stream "socks"
 346                                                     nil
 347                                                     (nth 1 server-info)
 348                                                     (nth 2 server-info)))
 349           (info (make-hash-table :size 13))
 350           (authtype nil))
 351
 352       ;; Initialize process and info about the process
 353       (set-process-filter proc 'socks-filter)
 354       (process-kill-without-query proc)
 355       (puthash proc info socks-connections)
 356       (puthash 'state socks-state-waiting-for-auth info)
 357       (puthash 'authtype socks-authentication-failure info)
 358       (puthash 'server-protocol (nth 3 server-info) info)
 359       (puthash 'server-name (nth 1 server-info) info)
 360       (case (nth 3 server-info)
 361         (http
 362          ;; Don't really have to do any connection setup under http
 363          nil)
 364         (4
 365          ;; Don't really have to do any connection setup under v4
 366          nil)
 367         (5
 368          ;; Need to handle all the authentication crap under v5
 369          ;; Send what we think we can handle for authentication types
 370          (process-send-string proc (format "%c%s" socks-version
 371                                            (socks-build-auth-list)))
 372
 373          ;; Basically just do a select() until we change states.
 374          (socks-wait-for-state-change proc info socks-state-waiting-for-auth)
 375          (setq authtype (gethash 'authtype info))
 376          (cond
 377           ((= authtype socks-authentication-null)
 378            (and socks-debug (message "No authentication necessary")))
 379           ((= authtype socks-authentication-failure)
 380            (error "No acceptable authentication methods found."))
 381           (t
 382            (let* ((auth-type (gethash 'authtype info))
 383                   (auth-handler (assoc auth-type socks-authentication-methods))
 384                   (auth-func (and auth-handler (cdr (cdr auth-handler))))
 385                   (auth-desc (and auth-handler (car (cdr auth-handler)))))
 386              (set-process-filter proc nil)
 387              (if (and auth-func (fboundp auth-func)
 388                       (funcall auth-func proc))
 389                  nil                    ; We succeeded!
 390                (delete-process proc)
 391                (error "Failed to use auth method: %s (%d)"
 392                       (or auth-desc "Unknown") auth-type))
 393              )
 394            )
 395           )
 396          (puthash 'state socks-state-authenticated info)
 397          (set-process-filter proc 'socks-filter)))
 398       proc)))
 399
 400 (defun socks-send-command (proc command atype address port)
 401   (let ((addr (cond
 402                ((or (= atype socks-address-type-v4)
 403                     (= atype socks-address-type-v6))
 404                 address)
 405                ((= atype socks-address-type-name)
 406                 (format "%c%s" (length address) address))
 407                (t
 408                 (error "Unkown address type: %d" atype))))
 409         (info (gethash proc socks-connections))
 410         request version)
 411     (or info (error "socks-send-command called on non-SOCKS connection %S"
 412                     proc))
 413     (puthash 'state socks-state-waiting info)
 414     (setq version (gethash 'server-protocol info))
 415     (case version
 416       (http
 417        (setq request (format (eval-when-compile
 418                                (concat
 419                                 "CONNECT %s:%d HTTP/1.0\r\n"
 420                                 "User-Agent: Emacs/SOCKS v1.0\r\n"
 421                                 "\r\n"))
 422                              (case atype
 423                                (socks-address-type-name address)
 424                                (otherwise
 425                                 (error "Unsupported address type for HTTP: %d" atype)))
 426                              port)))
 427       (4
 428        (setq request (format
 429                       "%c%c%c%c%s%s%c"
 430                       version           ; version
 431                       command           ; command
 432                       (lsh port -8)     ; port, high byte
 433                       (- port (lsh (lsh port -8) 8)) ; port, low byte
 434                       addr              ; address
 435                       (user-full-name)  ; username
 436                       0                 ; terminate username
 437                       )))
 438       (5
 439        (setq request (format
 440                       "%c%c%c%c%s%c%c"
 441                       version           ; version
 442                       command           ; command
 443                       0                 ; reserved
 444                       atype             ; address type
 445                       addr              ; address
 446                       (lsh port -8)     ; port, high byte
 447                       (- port (lsh (lsh port -8) 8)) ; port, low byte
 448                       )))
 449       (otherwise
 450        (error "Unknown protocol version: %d" version)))
 451     (process-send-string proc request)
 452     (socks-wait-for-state-change proc info socks-state-waiting)
 453     (process-status proc)
 454     (if (= (or (gethash 'reply info) 1) socks-response-success)
 455         nil                             ; Sweet sweet success!
 456       (delete-process proc)
 457       (error "SOCKS: %s" (nth (or (gethash 'reply info) 1) socks-errors)))
 458     proc))
 459
 460 \f
 461 ;; Replacement functions for open-network-stream, etc.
 462 (defvar socks-noproxy nil
 463   "*List of regexps matching hosts that we should not socksify connections to")
 464
 465 (defun socks-find-route (host service)
 466   (let ((route socks-server)
 467         (noproxy socks-noproxy))
 468     (while noproxy
 469       (if (eq ?! (aref (car noproxy) 0))
 470           (if (string-match (substring (car noproxy) 1) host)
 471               (setq noproxy nil))
 472         (if (string-match (car noproxy) host)
 473             (setq route nil
 474                   noproxy nil)))
 475       (setq noproxy (cdr noproxy)))
 476     route))
 477
 478 (defvar socks-override-functions nil
 479   "*Whether to overwrite the open-network-stream function with the SOCKSified
 480 version.")
 481
 482 (if (fboundp 'socks-original-open-network-stream)
 483     nil                                 ; Do nothing, we've been here already
 484   (fset 'socks-original-open-network-stream
 485         (symbol-function 'open-network-stream))
 486   (if socks-override-functions
 487       (fset 'open-network-stream 'socks-open-network-stream)))
 488
 489 (defvar socks-services-file "/etc/services")
 490 (defvar socks-tcp-services (make-hash-table :size 13 :test 'equal))
 491 (defvar socks-udp-services (make-hash-table :size 13 :test 'equal))
 492
 493 (defun socks-parse-services ()
 494   (if (not (and (file-exists-p socks-services-file)
 495                 (file-readable-p socks-services-file)))
 496       (error "Could not find services file: %s" socks-services-file))
 497   (save-excursion
 498     (clrhash socks-tcp-services)
 499     (clrhash socks-udp-services)
 500     (set-buffer (get-buffer-create " *socks-tmp*"))
 501     (erase-buffer)
 502     (insert-file-contents socks-services-file)
 503     ;; Nuke comments
 504     (goto-char (point-min))
 505     (while (re-search-forward "#.*" nil t)
 506       (replace-match ""))
 507     ;; Nuke empty lines
 508     (goto-char (point-min))
 509     (while (re-search-forward "^[ \t\n]+" nil t)
 510       (replace-match ""))
 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]+\\)"
 515                                 nil t)
 516         (setq name (downcase (match-string 1))
 517               port (string-to-int (match-string 2))
 518               type (downcase (match-string 3)))
 519         (puthash name port (if (equal type "udp")
 520                                socks-udp-services
 521                              socks-tcp-services))))))
 522
 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)))
 529
 530 (defun socks-open-network-stream (name buffer host service)
 531   (let* ((route (socks-find-route host service))
 532          proc info version atype)
 533     (if (not route)
 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))
 538       (case version
 539         (4
 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))
 545         (otherwise
 546          (setq atype socks-address-type-name)))
 547       (socks-send-command proc
 548                           socks-connect-command
 549                           atype
 550                           host
 551                           (if (stringp service)
 552                               (socks-find-services-entry service)
 553                             service))
 554       (puthash 'buffer buffer info)
 555       (puthash 'host host info)
 556       (puthash 'service host info)
 557       (set-process-filter proc nil)
 558       (set-process-buffer proc (if buffer (get-buffer-create buffer)))
 559       proc)))
 560
 561 ;; Authentication modules go here
 562 \f
 563 ;; Basic username/password authentication, ala RFC 1929
 564 (socks-register-authentication-method 2 "Username/Password"
 565                                       'socks-username/password-auth)
 566
 567 (defconst socks-username/password-auth-version 1)
 568
 569 (if (not (fboundp 'char-int))
 570     (fset 'char-int 'identity))
 571
 572 (defun socks-username/password-auth-filter (proc str)
 573   (let ((info (gethash proc socks-connections)))
 574     (or info (error "socks-filter called on non-SOCKS connection %S" proc))
 575     (puthash 'scratch (concat (gethash 'scratch info) str) info)
 576     (if (< (length (gethash 'scratch info)) 2)
 577         nil
 578       (puthash 'password-auth-status (char-int
 579                                          (aref (gethash 'scratch info) 1))
 580                   info)
 581       (puthash 'state socks-state-authenticated info))))
 582
 583 (defun socks-username/password-auth (proc)
 584   (let* ((info (gethash proc socks-connections))
 585          (state (gethash 'state info)))
 586     (if (not socks-password)
 587         (setq socks-password (read-passwd
 588                               (format "Password for %s@%s: "
 589                                       socks-username
 590                                       (gethash 'server-name info)))))
 591     (puthash 'scratch "" info)
 592     (set-process-filter proc 'socks-username/password-auth-filter)
 593     (process-send-string proc
 594                          (format "%c%c%s%c%s"
 595                                  socks-username/password-auth-version
 596                                  (length socks-username)
 597                                  socks-username
 598                                  (length socks-password)
 599                                  socks-password))
 600     (socks-wait-for-state-change proc info state)
 601     (= (gethash 'password-auth-status info) 0)))
 602
 603 \f
 604 ;; More advanced GSS/API stuff, not yet implemented - volunteers?
 605 ;; (socks-register-authentication-method 1 "GSS/API" 'socks-gssapi-auth)
 606
 607 (defun socks-gssapi-auth (proc)
 608   nil)
 609
 610 \f
 611 ;; CHAP stuff
 612 ;; (socks-register-authentication-method 3 "CHAP" 'socks-chap-auth)
 613 (defun socks-chap-auth (proc)
 614   nil)
 615
 616 \f
 617 ;; CRAM stuff
 618 ;; (socks-register-authentication-method 5 "CRAM" 'socks-cram-auth)
 619 (defun socks-cram-auth (proc)
 620   nil)
 621
 622 \f
 623 (defcustom socks-nslookup-program "nslookup"
 624   "*If non-NIL then a string naming the nslookup program."
 625   :type '(choice (const :tag "None" :value nil) string)
 626   :group 'socks)
 627
 628 (defun socks-nslookup-host (host)
 629   "Attempt to resolve the given HOSTNAME using nslookup if possible."
 630   (interactive "sHost:  ")
 631   (if socks-nslookup-program
 632       (let ((proc (start-process " *nslookup*" " *nslookup*"
 633                                  socks-nslookup-program host))
 634             (res host))
 635         (process-kill-without-query proc)
 636         (save-excursion
 637           (set-buffer (process-buffer proc))
 638           (while (progn
 639                    (accept-process-output proc)
 640                    (memq (process-status proc) '(run open))))
 641           (goto-char (point-min))
 642           (if (re-search-forward "Name:.*\nAddress\\(es\\)?: *\\([0-9.]+\\)$" nil t)
 643               (progn
 644                 (setq res (buffer-substring (match-beginning 2)
 645                                             (match-end 2))
 646                       res (mapcar 'string-to-int (split-string res "\\.")))))
 647           (kill-buffer (current-buffer)))
 648         res)
 649     host))
 650
 651 (provide 'socks)