proxy.scm - holymoly - A tor enabled gopher client written in CHICKEN scheme
 (HTM) git clone git://vernunftzentrum.de/holymoly.git
 (DIR) Log
 (DIR) Files
 (DIR) Refs
 (DIR) README
 (DIR) LICENSE
       ---
       proxy.scm (4612B)
       ---
            1 (module socksv5-proxy
            2 
            3  (connect/socksv5)
            4 
            5  (import (chicken base) (chicken foreign) (chicken condition) scheme)
            6  (import (chicken tcp) srfi-4 srfi-13 bitstring)
            7 
            8  (define (raise-error loc subtype msg . args)
            9    (signal (make-composite-condition
           10             (make-property-condition 'exn 'message msg 'location loc 'arguments args)
           11             (make-property-condition 'i/o)
           12             (make-property-condition 'net)
           13             (make-property-condition 'socksv5-proxy 'type subtype))))
           14 
           15  (define connect-response-strings
           16    '("Succeeded"
           17      "General SOCKS server failure"
           18      "Connection not allowed by ruleset"
           19      "Network unreachable"
           20      "Connection refused"
           21      "TTL Expired"
           22      "Command not supported"
           23      "Address type not supported"))
           24 
           25  (define (connect-response->string response-type)
           26    (if (> (length connect-response-strings) response-type)
           27      (list-ref connect-response-strings response-type)
           28      "unassigned"))
           29 
           30  (define (connect/socksv5 proxy proxy-port destination destination-port)
           31    (parameterize ((tcp-connect-timeout #f)
           32                   (tcp-read-timeout #f))
           33                  (let-values (((i o) (tcp-connect proxy proxy-port)))
           34                    (write-u8vector '#u8(5 1 0) o)
           35                    (let ((r (read-u8vector 2 i)))
           36                      (unless (equal? r '#u8(5 0))
           37                              (close-input-port i)
           38                              (close-output-port o)
           39                              (raise-error 'connect/socksv5 'auth "Unsupported authentication for proxy " r))
           40                      (write-u8vector
           41                       (bitstring->u8vector
           42                        (bitconstruct
           43                         (5 8) ; Version
           44                         (1 8) ; connect
           45                         (0 8) ; reserved
           46                         (3 8) ; FQDN, do the resolution for us
           47                         ((string-length destination) 8)
           48                         (destination bitstring)
           49                         (destination-port 16 big)))
           50                       o)
           51                      (flush-output o)
           52                      (let* ((resp (read-u8vector 10 i))
           53                             (response
           54                              (bitmatch resp
           55                                        (((Version 8)
           56                                          (Reply-field 8)
           57                                          (Reserved 8)
           58                                          (Address-Type 8)
           59                                          (check (= Address-Type 1))
           60                                          (bind-address 32 bitstring)
           61                                          (bind-port 16 big))
           62                                         (list Version Reserved Reply-field Address-Type (bitstring->u8vector bind-address) bind-port))
           63                                        (((Version 8) 
           64                                          (Reply-field 8)
           65                                          (Reserved 8)
           66                                          (Address-Type 8)
           67                                          (check (= Address-Type 4))
           68                                          (bind-address 64 bitsring)
           69                                          (bind-port 16 big)) 
           70                                         (list Version Reserved Reply-field Address-Type (bitstring->u8vector bind-address) bind-port))
           71                                        (((Version 8) 
           72                                          (Reply-field 8)
           73                                          (Reserved 8)
           74                                          (Address-Type 8)
           75                                          (check (= Address-Type 3))
           76                                          (bind-address-length 8)
           77                                          (bitmatch (read-u8vector (- (+ bind-address-length 2) 4) i)
           78                                                    (((bind-address (* 8 bind-address-length) bitstring)
           79                                                      (bind-port 16 big))
           80                                                     (list Version Reserved Reply-field Address-Type (bitstring->list bind-address) bind-port)))))
           81                                        (else (raise-error 'connect/socksv5 'connect "Parse error in socket response " resp)))))
           82                        (if (zero? (cadr response)) ; if reply field is zero all is well
           83                            (values i o response)
           84                            (begin
           85                              (close-input-port i)
           86                              (close-output-port o)
           87                              (raise-error 'connect/socksv5 'connect "Connect error" (connect-response->string (car response)))))))))))
           88