110 lines
4.2 KiB
Racket
110 lines
4.2 KiB
Racket
#lang racket/base
|
||
;; A proxy HTTP server -- don’t get your hopes up it’s for testing and
|
||
;; only proxies ports, probably oozes security leaks and I wouldn’t be
|
||
;; surprised if it leaked fids too.
|
||
(require racket/port racket/match racket/tcp "generic-server.rkt")
|
||
|
||
(provide server
|
||
current-conn-timeout)
|
||
|
||
(define (http-tunnel-serve in out)
|
||
(let/ec
|
||
ec
|
||
(define-syntax-rule (out/flush fmt args ...)
|
||
(begin (fprintf out fmt args ...)
|
||
(flush-output out)))
|
||
|
||
(define request-lines (for/list ((l (in-lines in 'return-linefeed))
|
||
#:break (string=? l ""))
|
||
l))
|
||
|
||
;; frankly, I don’t care about the headers... it’s just the request string
|
||
;; I’m interested in
|
||
(match request-lines
|
||
[(cons (regexp #px"^(CONNECT)\\s+(\\S+):(\\d+)(\\s+HTTP/\\S+)?$"
|
||
(list _ method connect-host (app string->number connect-port) _)) _)
|
||
(define-values (connect:from connect:to)
|
||
(with-handlers ([exn:fail? (lambda (x)
|
||
;; any better ideas as to a good status code?
|
||
(out/flush "HTTP/1.1 410 Gone\r\n\r\n")
|
||
(ec))])
|
||
(tcp-connect connect-host connect-port)))
|
||
(file-stream-buffer-mode connect:to 'none)
|
||
(file-stream-buffer-mode connect:from 'none)
|
||
(out/flush "HTTP/1.1 200 Connection Established\r\n\r\n")
|
||
(define copy-in-to-connect:to-thread
|
||
(thread (lambda ()
|
||
(copy-port in connect:to)
|
||
(close-output-port connect:to))))
|
||
(define copy-connect:from-to-out-thread
|
||
(thread (lambda ()
|
||
(copy-port connect:from out)
|
||
(close-output-port out))))
|
||
(thread-wait copy-in-to-connect:to-thread)
|
||
(thread-wait copy-connect:from-to-out-thread)]
|
||
[(cons (regexp #px"^(\\S+)\\s+(\\S+)(\\s+HTTP/\\S+)?$"
|
||
(list request method request-uri http-version)) _)
|
||
(out/flush "HTTP/1.1 405 Method Not Allowed\r\n\r\n")]
|
||
[_ (out/flush "HTTP/1.1 400 Bad Request\r\n\r\n")])))
|
||
|
||
(define (server)
|
||
(serve http-tunnel-serve))
|
||
|
||
(module+
|
||
main
|
||
(define-values (the-port server-thread shutdown-server)
|
||
(server))
|
||
(thread-wait server-thread))
|
||
|
||
(module+
|
||
test
|
||
(module config info
|
||
(define timeout 300))
|
||
(require rackunit)
|
||
|
||
(require (prefix-in es: "echo-server.rkt"))
|
||
|
||
(define-values (proxy-listen-port server-thread shutdown-server)
|
||
(server))
|
||
|
||
(define-values (echo-port es:server-thread es:shutdown-server) (es:server))
|
||
|
||
(let ((old-exit-handler (exit-handler)))
|
||
(exit-handler (lambda (exit-code)
|
||
(shutdown-server)
|
||
(es:shutdown-server)
|
||
(old-exit-handler exit-code))))
|
||
|
||
(define (connect/test method uri http-version
|
||
#:headers (headers '())
|
||
#:body (body #f))
|
||
|
||
(define-values (cl:from cl:to) (tcp-connect "localhost" proxy-listen-port))
|
||
(file-stream-buffer-mode cl:from 'none)
|
||
(file-stream-buffer-mode cl:to 'none)
|
||
|
||
(if http-version
|
||
(fprintf cl:to "~a ~a ~a\r\n" method uri http-version)
|
||
(fprintf cl:to "~a ~a\r\n" method uri))
|
||
|
||
(for-each (lambda (h) (fprintf cl:to "~a\r\n" h)) headers)
|
||
(fprintf cl:to "\r\n") ; end headers
|
||
|
||
;; Not interested in any fancy interaction here... just see what the response is
|
||
(when body (write-string body cl:to))
|
||
(flush-output cl:to)
|
||
(close-output-port cl:to)
|
||
(begin0
|
||
(port->string cl:from)
|
||
(tcp-abandon-port cl:to)
|
||
(tcp-abandon-port cl:from)))
|
||
|
||
(check-match (connect/test "GET" "/" #f) (regexp #px"^HTTP/\\S+\\s+405"))
|
||
(check-match (connect/test "A B" "/" #f) (regexp #px"^HTTP/\\S+\\s+400"))
|
||
(check-match (connect/test "CONNECT" "q.com:9887" #f) (regexp #px"^HTTP/\\S+\\s+410"))
|
||
(check-match (connect/test "CONNECT" (format "localhost:~a" echo-port)
|
||
#f #:body "blah blah blah!")
|
||
(regexp #px"^HTTP/\\S+\\s+200.*blah!$"))
|
||
|
||
)
|