navi2ch-socks.el

   1 ;;; navi2ch-socks.el --- socks support for navi2ch -*- coding: iso-2022-7bit; lexical-binding: t; -*-
   2
   3 ;; Code:
   4 (defconst navi2ch-socks-ident
   5   "$Id$")
   6
   7 (eval-when-compile
   8   (require 'cl-lib)
   9   (require 'navi2ch-decls)
  10   (require 'navi2ch-inline))
  11
  12 (require 'navi2ch-vars)
  13 (require 'socks)
  14 (require 'nadvice)
  15 (require 'gnutls)
  16 (require 'nsm)
  17 (require 'puny)
  18
  19 ;;
  20 ;;
  21 (defun navi2ch-socks--open-connection (server-info opener name buffer)
  22   (save-excursion
  23     (navi2ch-log 'LOG_INFO "SOCKS connecting socks server %s:%s type: %s"
  24                  (nth 1 server-info) (nth 2 server-info) (if (nth 4 server-info) 'tls nil))
  25     (let ((proc
  26            (funcall opener name buffer (nth 1 server-info) (nth 2 server-info)
  27                     :type (if (nth 4 server-info) 'tls 'network)))
  28           (authtype nil)
  29           (version (nth 3 server-info)))
  30
  31       ;; Initialize process and info about the process
  32       (set-process-filter proc #'socks-filter)
  33       (set-process-query-on-exit-flag proc nil)
  34       (process-put proc 'socks t)
  35       (process-put proc 'socks-state socks-state-waiting-for-auth)
  36       (process-put proc 'socks-authtype socks-authentication-failure)
  37       (process-put proc 'socks-server-protocol version)
  38       (process-put proc 'socks-server-name (nth 1 server-info))
  39       (process-put proc 'navi2ch-socks t)
  40
  41       (cond
  42        ((equal version 'http)
  43         ;; Don't really have to do any connection setup under http
  44         nil)
  45        ((equal version 4)
  46         ;; Don't really have to do any connection setup under v4
  47         nil)
  48        ((equal version 5)
  49         ;; Need to handle all the authentication crap under v5
  50         ;; Send what we think we can handle for authentication types
  51         (process-send-string proc (format "%c%s" socks-version
  52                                           (socks-build-auth-list)))
  53
  54         ;; Basically just do a select() until we change states.
  55         (socks-wait-for-state-change proc socks-state-waiting-for-auth)
  56         (setq authtype (process-get proc 'socks-authtype))
  57         (cond
  58          ((= authtype socks-authentication-null)
  59           (and socks-debug (message "No authentication necessary")))
  60          ((= authtype socks-authentication-failure)
  61           (error "No acceptable authentication methods found"))
  62          (t
  63           (let* ((auth-type (process-get proc 'socks-authtype))
  64                  (auth-handler (assoc auth-type socks-authentication-methods))
  65                  (auth-func (and auth-handler (cdr (cdr auth-handler))))
  66                  (auth-desc (and auth-handler (car (cdr auth-handler)))))
  67             (set-process-filter proc nil)
  68             (if (and auth-func (fboundp auth-func)
  69                      (funcall auth-func proc))
  70                 nil                     ; We succeeded!
  71               (delete-process proc)
  72               (error "Failed to use auth method: %s (%d)"
  73                      (or auth-desc "Unknown") auth-type))
  74             )
  75           )
  76          )
  77         (process-put proc 'socks-state socks-state-authenticated)
  78         (process-put proc 'socks-scratch "")
  79         (set-process-filter proc #'socks-filter)))
  80       proc)))
  81
  82 (defun navi2ch-socks--open-network-stream (route opener name buffer host service &rest rest)
  83   (let* ((proc (navi2ch-socks--open-connection route opener name buffer))
  84          (version (process-get proc 'socks-server-protocol))
  85          (addr-info
  86           (cond ((eq version 4)
  87                  (let* ((addrs (network-lookup-address-info host))
  88                         (v4-addr (and addrs
  89                                    (cl-find-if
  90                                     (lambda (a) (length= a 5)) addrs))))
  91                    (unless v4-addr
  92                      (error "%s: does not have IPv4 address. use socks5 server" host))
  93                    (cons socks-address-type-v4
  94                          (apply #'unibyte-string
  95                                 (seq-into (seq-take v4-addr 4) 'list)))))
  96                 ((eq version 5)
  97                  (cons socks-address-type-name host))
  98                 ((eq version 'http)
  99                  (cons socks-address-type-name
 100                        (if (string-match ":" host)
 101                            (concat "[" host "]")
 102                          host)))
 103                 (t (error "%s: uknown socks protocol version" version)))))
 104     (navi2ch-log 'LOG_INFO "SOCKS dig a tunnel to %s:%s type: %s"
 105                            host service (if (memq (plist-get rest :type) '(tls ssl)) 'tls nil))
 106     (socks-send-command proc
 107                         socks-connect-command
 108                         (car addr-info) ; atype
 109                         (cdr addr-info) ; addr
 110                         (if (stringp service)
 111                             (or
 112                              (socks-find-services-entry service)
 113                              (error "Unknown service: %s" service))
 114                           service))
 115     (process-put proc 'socks-buffer buffer)
 116     (process-put proc 'socks-host (cdr addr-info))
 117     (process-put proc 'socks-service service)
 118     (set-process-filter proc nil)
 119     ; (set-process-buffer proc (and buffer (get-buffer-create buffer)))
 120
 121     (cond ((memq (plist-get rest :type) '(tls ssl))
 122            (navi2ch-log 'LOG_INFO "SOCKS negotiate a SSL/TLS connection with %s" (puny-encode-domain host))
 123            (gnutls-negotiate
 124             :process proc :type 'gnutls-x509pki
 125             :hostname (puny-encode-domain host))
 126            (nsm-verify-connection proc host service))
 127           (t proc))))
 128
 129 (defmacro navi2ch-socks--stream-opener (socks stream-opener _name _buffer _host _service _rest)
 130   `(let ((server-info
 131           (list "navi2ch socks server"
 132                 (navi2ch-net-url-host ,socks)
 133                 (or (navi2ch-net-url-port ,socks) 1080)
 134                 (cond ((string= (navi2ch-net-url-protocol ,socks) "socks4") 4)
 135                       ((string= (navi2ch-net-url-protocol ,socks) "socks5") 5)
 136                       ((member (navi2ch-net-url-protocol ,socks) '("http" "https")) 'http)
 137                       (t (error "%s: unsopported protocol" (navi2ch-net-url-protocol ,socks))))
 138                 (string-suffix-p "s" (navi2ch-net-url-protocol ,socks))))
 139          (user (or navi2ch-socks-userid (navi2ch-net-url-user ,socks)))
 140          (password (or navi2ch-socks-password (navi2ch-net-url-password ,socks)))
 141          (stream-opener ,stream-opener))
 142
 143      (lambda (name buffer host service &rest rest)
 144        (let ((buffer (get-buffer-create buffer)))
 145          (with-current-buffer buffer
 146            (set (make-local-variable 'socks-username) user)
 147            (set (make-local-variable 'socks-password) password))
 148          (apply #'navi2ch-socks--open-network-stream server-info stream-opener name buffer host service rest)))))
 149
 150 (defun navi2ch-socks-open-network-stream (name buffer host service &rest rest)
 151   (let ((socks-proxy (navi2ch-net-parse-url navi2ch-socks-server))
 152         (http-proxy (navi2ch-net-parse-url navi2ch-net-http-proxy))
 153         (stream-opener #'open-network-stream))
 154
 155     (let ((stream-opener
 156            (if socks-proxy
 157                (navi2ch-socks--stream-opener socks-proxy stream-opener name buffer host service rest)
 158              stream-opener)))
 159       (let ((stream-opener
 160              (if (and http-proxy
 161                       (memq (plist-get rest :type) '(tls ssl)))
 162                  (navi2ch-socks--stream-opener http-proxy stream-opener name buffer host service rest)
 163                stream-opener)))
 164
 165         (apply stream-opener name buffer host service rest)))))
 166
 167 (advice-add 'socks-username/password-auth :around
 168             (lambda (old-func proc)
 169               (if (process-get proc 'navi2ch-socks)
 170                   (with-current-buffer (process-buffer proc)
 171                     (funcall old-func proc))
 172                 (funcall old-func proc)))
 173             '((name . socks-username/password-auth:around)))
 174
 175
 176 (add-hook 'navi2ch-hook
 177           (lambda ()
 178             ;; squid\e$A$O\e(BHTTP/1.1 200 Connection established\n\n\e$A$r75$9$,\e(B
 179             ;; socks-filter\e$A$O\e$(I%\%w\e$A$7$F$$$J$$$N$G\e(Badvice
 180             (advice-add 'socks-filter :filter-args
 181                         (lambda (args)
 182                           (if (and (= (process-get (car args) 'socks-state) socks-state-waiting)
 183                                    (not (string-search "\r\n\r\n" (cadr args))))
 184                               (list (car args) (string-replace "\n\n" "\r\n\r\n" (cadr args)))
 185                             args))
 186                         '((name . "navi2ch-socks-filter:filter-args")))))
 187
 188 (add-hook 'navi2ch-exit-hook
 189           (lambda ()
 190             (advice-remove 'socks-filter "navi2ch-socks-filter:filter-args")))
 191
 192 (provide 'navi2ch-socks)