Skip to content

Instantly share code, notes, and snippets.

@pclouds
Created March 1, 2016 05:50
Show Gist options
  • Save pclouds/9dd7d27e76b7db188dcb to your computer and use it in GitHub Desktop.
Save pclouds/9dd7d27e76b7db188dcb to your computer and use it in GitHub Desktop.
;; Define your own rules here
;; return a pair of server address and port
(define (choose-proxy host)
(values host 80))
(define (http-read-line port)
(read-line port #\newline #t))
(define (read-write read-port write-port)
(define (do-read-write read-port write-port)
(let ((text (read-char read-port)))
(cond ((eof-object? text)
(close-port write-port))
(else
(write-char text write-port)
(force-output write-port)
(do-read-write read-port write-port)))))
(with-exception-catcher
(lambda (e)
(and (port? read-port) (close-port read-port))
(and (port? write-port) (close-port write-port)))
(lambda ()
(do-read-write read-port write-port))))
(define (make-proxy port)
;; Read lines from port until reaching empty line
;; construct a list of lines with read order
(define (read-http-headers port)
(let loop ((headers '()))
(let ((line (http-read-line port)))
(cond ((eof-object? line)
#f)
((string=? line "\r\n")
(reverse headers))
(else
(loop (cons line headers)))))))
;; trim #\space #\newline and #\return from string
(define (trim-string string)
(let* ((len (string-length string))
(start (let loop ((idx 0))
(if (and (< idx len)
(or (eq? #\space (string-ref string idx))
(eq? #\newline (string-ref string idx))
(eq? #\return (string-ref string idx))))
(loop (+ idx 1))
idx)))
(end (let loop ((idx (- len 1)))
(if (and (>= idx 0)
(or (eq? #\space (string-ref string idx))
(eq? #\newline (string-ref string idx))
(eq? #\return (string-ref string idx))))
(loop (- idx 1))
(+ idx 1)))))
(substring string start end)))
(define (get-attribute string attr-name)
(let ((idx (+ 1 (string-length attr-name))) ; 1 for colon
(len (string-length string)))
(cond ((eq? idx #f)
#f)
(else
(trim-string (substring string idx len))))))
(let ((request (http-read-line port)))
(if (string-ci=? "CONNECT " (substring request 0 (string-length "CONNECT ")))
(let* ((prefix (string-length "CONNECT "))
(headers (read-http-headers port))
(colon-idx (let loop ((idx prefix))
(if (char=? #\: (string-ref request idx))
idx
(loop (+ idx 1)))))
(space-idx (let loop ((idx colon-idx))
(if (char=? #\space (string-ref request idx))
idx
(loop (+ idx 1)))))
(host (substring request prefix colon-idx))
(port-number (string->number (substring request (+ colon-idx 1) space-idx)))
(newport (open-tcp-client (list port-number: port-number
server-address: host))))
(print "Passing through " host " " port-number "\n")
(display "HTTP/1.0 200 OK\r\n\r\n" port)
(force-output port)
newport)
(let* ((headers (read-http-headers port)) ; else
(host (let loop ((lst (cdr headers)))
(cond ((eq? lst '())
#f)
((string-ci=? "Host: " (substring (car lst) 0 (string-length "Host: ")))
(car lst))
(else
(loop (cdr lst)))))))
(cond ((string? host)
(print request host)
(call-with-values
(lambda ()
(choose-proxy (get-attribute host "Host")))
(lambda (server-address port-number)
(let ((newport (open-tcp-client (list port-number: port-number
server-address: server-address))))
(display request newport)
(let loop ((lst headers))
(display (car lst) newport)
(and (pair? (cdr lst))
(loop (cdr lst))))
(display "\r\n" newport) ; header end
(force-output newport)
newport))))
(else
#f))))))
(define (redirect sock)
(let* ((newsock (make-proxy sock))
(read-thread (make-thread (lambda() (read-write sock newsock))))
(write-thread (make-thread (lambda() (read-write newsock sock)))))
;(display text newsock)
;(force-output newsock)
(thread-start! read-thread)
(thread-start! write-thread)))
(define (listen-thread sock)
(redirect (read sock))
(listen-thread sock))
(listen-thread (open-tcp-server 8080))
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment