proxy/proxy.ss
(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)


  ; Top level connection handling ----------------
  
  ;; run-proxy
  ;;     : (bytes bytes (hash-table-of bytes bytes) -> (U path #f))
  ;;       (U string #f)
  ;;       integer
  ;;       integer
  ;;       tcp^
  ;;    -> (-> void)
  (define (run-proxy request->path hostname port max-waiting tcp@)
    (define-values/invoke-unit tcp@ (import) (export tcp^))

    (define custodian (make-custodian))
    
    ;; handle-connection : input-port output-port -> any
    (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?
                       ;; This exception isn't too serious!
                       (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))))))
    
    ; Request handling -----------------------------

    (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)])))
    
    ;; dispatch : connection -> void
    (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))
  
  ; SBCS specific stuff --------------------------
  
  ;; script-url->path : bytes bytes (hash-table-of bytes bytes) -> (U path #f)
  (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]))
  
  )