(module proxy mzscheme
(require (lib "thread.ss")
(lib "unit.ss")
(lib "plt-match.ss")
(lib "port.ss")
(lib "tcp-sig.ss" "net")
(lib "tcp-unit.ss" "net")
(lib "uri-codec.ss" "net")
(lib "url.ss" "net")
(lib "list.ss" "srfi" "1")
(lib "time.ss" "srfi" "19")
(lib "cut.ss" "srfi" "26")
(lib "connection-manager.ss" "web-server" "private")
(lib "request.ss" "web-server" "private")
(lib "request-structs.ss" "web-server" "private")
(file "base.ss")
(file "io.ss")
(file "http.ss"))
(provide run-proxy)
(define (run-proxy request->path hostname port max-waiting tcp@)
(define-values/invoke-unit tcp@ (import) (export tcp^))
(define custodian (make-custodian))
(define (handle-connection ip op)
(define conn
(new-connection 30 ip op (current-custodian) #f))
(with-handlers ([exn:fail:network?
(lambda (e)
(kill-connection! conn)
(raise e))]
[exn:proxy?
(lambda (e)
(kill-connection! conn)
(void))])
(parameterize ([current-id (get-next-id)])
(let connection-loop ()
(debug "request: start")
(dispatch conn)
(if (connection-close? conn)
(begin (kill-connection! conn)
(debug "connection closed"))
(connection-loop))))))
(define (get-remote-ports headers)
(let ([host+port (hash-table-get headers #"Host")])
(match (regexp-match #rx#"([^:]+):(.*)" host+port)
[(list _ host port)
(tcp-connect (bytes->string/utf-8 host) (string->number (bytes->string/utf-8 port)))]
[other
(tcp-connect (bytes->string/utf-8 host+port) 80)])))
(define (dispatch connection)
(define headers (make-hash-table 'equal))
(define (finish-headers headers lines method url)
(debug "Received request: ~a~n" url)
(let ([local-path (request->path method url headers)]
[conn-header (hash-table-get headers #"Proxy-Connection" #f)])
(debug "request: proxy-connection: ~a" conn-header)
(when (and conn-header (bytes=? conn-header #"close"))
(set-connection-close?! connection #t))
(if local-path
(send-local-response connection local-path)
(let-values ([(remote-input remote-output)
(get-remote-ports headers)])
(debug "remote ports: ~a ~a~n" remote-input remote-output)
(for-each (lambda (line)
(write-http-line remote-output line))
lines)
(write-bytes #"Pragma: no-cache\r\n" remote-output)
(write-bytes #"Cache-Control: no-cache\r\n" remote-output)
(write-http-line remote-output #"")
(flush-output remote-output)
(when (equal? method #"POST")
(transfer-body connection remote-output headers))
(handle-response connection remote-input)))))
(let*-values (([request method url major minor]
(parse-request-line connection))
([lines]
(cons request
(parse-headers connection headers))))
(finish-headers headers lines method url)))
(define (handle-response connection remote-input)
(define headers (make-hash-table 'equal))
(define (finish-headers lines code)
(let ([conn-header (hash-table-get headers #"Proxy-Connection" #f)])
(debug "response: proxy-connection: ~a" conn-header)
(when (and conn-header (bytes=? conn-header #"close"))
(set-connection-close?! connection #t))
(for-each (lambda (line)
(write-http-line connection line))
lines)
(write-http-line connection #"")
(flush-output (connection-o-port connection))
(debug "response: finished headers")
(if (or (get-content-length headers)
(not (bytes=? code #"304")))
(transfer-body remote-input connection headers))))
(let*-values (([status major minor code message]
(parse-status-line remote-input))
([lines]
(cons status
(parse-headers remote-input headers))))
(finish-headers lines code)))
(define (send-local-response connection path)
(let ([in (open-input-file path)]
[out (connection-o-port connection)]
[date (date->string (time-tai->date (current-time time-tai)) "~a, ~d ~b ~Y ~H:~M:~S GMT")]
[type (match (regexp-match #rx"\\.(.+)$" (path->string path))
[(list _ extension)
(cond [(equal? extension "html") "text/html"]
[(equal? extension "js") "text/javascript"]
[else "text/plain"])]
[other "text/plain"])]
[length (file-size path)])
(debug "local response")
(write-bytes #"HTTP/1.1 200 Okay\r\n" out)
(write-bytes (string->bytes/utf-8 (format "Date: ~a\r\n" date)) out)
(write-bytes #"Server: Untyped testing proxy\r\n" out)
(write-bytes (string->bytes/utf-8 (format "Last-Modified: ~a\r\n" date)) out)
(write-bytes (string->bytes/utf-8 (format "Content-Type: ~a\r\n" type)) out)
(write-bytes (string->bytes/utf-8 (format "Content-Length: ~a\r\n" length)) out)
(write-bytes #"Via: 1.1 www2.sbcs.qmul.ac.uk\r\n" out)
(write-bytes #"\r\n" out)
(copy-port in out)
(close-input-port in)))
(parameterize ([current-custodian custodian])
(thread
(lambda ()
(with-handlers
([exn? (lambda (e)
(display "Proxy raised exception:\n")
(display e)
(display (exn-continuation-marks e))
(raise e))])
(display "Proxy starting\n")
(run-server port
(cut handle-connection <> <>)
#f
(lambda (exn) #f)
(cut tcp-listen <> <> <> hostname)
tcp-close
tcp-accept
tcp-accept/enable-break)
(display "Proxy ended\n")))))
(cut custodian-shutdown-all custodian))
(define (request->path method url headers)
(cond [(regexp-match #rx#"stress.html$" url)
(string->path "stress.html")]
[(regexp-match #rx#"stress.js$" url)
(string->path "stress.js")]
[else #f]))
)