metaproxy.scm

;; 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))