(use tcp srfi-4 bitstring)

(define (connect/socks proxy proxy-port destination destination-port)
  (parameterize ((tcp-connect-timeout #f)
                 (tcp-read-timeout #f))
    (let-values (((i o) (tcp-connect proxy proxy-port)))
      (write-u8vector '#u8(5 1 0) o)
      (let ((r (read-u8vector 2 i)))
        (unless (equal? r '#u8(5 0))
          (print "Unsupported authentication for proxy " r))
        (write-u8vector
         (bitstring->u8vector
          (bitconstruct
           (5 8) ; Version
           (1 8) ; connect
           (0 8) ; reserved
           (3 8) ; FQDN, do the resolution for us
           ((string-length destination) 8)
           (destination bitstring)
           (destination-port 16 big)))
         o)
        (flush-output o)
        (let* ((resp (read-u8vector 5 i))
               (response
                (bitmatch resp
                          (((Version 8)
                            (Reply-field 8)
                            (Reserved 8)
                            (Address-Type 8)
                            (bind-address-length 8)) ; usually 0 for connects
                           (bitmatch (read-u8vector (+ bind-address-length 2) i)
                                     (((bind-address (* 8 bind-address-length) bitstring)
                                       (bind-port 16 big))
                                      (list Reply-field Address-Type (list->string (bitstring->list bind-address)) bind-port))))
                          (else (error "Parse error in socket response " resp)))))
          (if (zero? (car response)) ; if reply field is zero all is well
              (values i o)
              (begin
                (close-input-port i)
                (close-output-port o)
                (error "Connection error " (car response)))))))))