(module http mzscheme

  (require
   (lib "plt-match.ss")
   (lib "connection-manager.ss" "web-server" "private")
   (file "io.ss")
   (file "base.ss"))
  
  (provide
   request-line-rx
   status-line-rx
   header-rx
   
   get-content-length

   parse-request-line
   parse-status-line
   parse-headers
   transfer-body)

  (define request-line-rx
    #rx#"([A-Z]+) (.+) HTTP/([0-9]).([0-9])")
  
  (define status-line-rx
    #rx#"HTTP/([0-9]).([0-9]) ([0-9]+) (.*)")

  (define header-rx
    #rx#"([^:]+): (.*)")
  
  ;; get-content-length : hash-table -> (U number #f)
  (define (get-content-length headers)
    (let ([bytes (hash-table-get headers #"Content-Length" #f)])
      (if bytes 
          (string->number (bytes->string/utf-8 bytes))
          #f)))

  ;; parse-request-line : connection -> (values bytes bytes bytes bytes bytes)
  ;;
  ;; (parse-request-line conn) -> request-line method url major minor
  (define (parse-request-line connection)
    (let ([request-line (read-http-line connection)])
      (if (eof-object? request-line)
          (begin
            (set-connection-close?! connection #t)
            (raise-exn exn:proxy
              "Request ended while reading request line\n"))
          (match (regexp-match request-line-rx request-line)
            [(list _ method url major minor)
             (values request-line method url major minor)]
            [err
             (raise-exn exn:proxy
               (format "Could not parse request line ~a\n" err))]))))
  
  ;; parse-status-line : connection
  ;;                   -> (values bytes bytes bytes bytes bytes)
  ;;
  ;; (parse-status-line conn) -> status-line major minor code message
  (define (parse-status-line connection)
    (let ([status-line (read-http-line connection)])
      (debug "status-line: ~a~n" status-line)
      (if (eof-object? status-line)
          (set-connection-close?! connection #t)
          (match (regexp-match status-line-rx status-line)
            [(list _ major minor code message)
             (values status-line major minor code message)]))))

  ;; parse-headers : connection hash-table -> (listof bytes)
  ;;
  ;; Parse the headers after the status line, returning then
  ;; in a list (in-order, so first header is first in the
  ;; list).  As a side-effect headers are added to the
  ;; hash-table keyed under the header name.
  (define (parse-headers connection headers)
    (let ([line (read-http-line connection)])
      (cond
       [(eof-object? line) null]
       [(bytes=? line #"") null]
       [else (match (regexp-match header-rx line)
               [(list _ name value)
                (hash-table-put! headers name value)
                (cons line (parse-headers connection headers))])])))

  ;; transfer-body : (U connection input-port) (U connection output-port) hash-table -> void
  ;;
  ;; Copy HTTP body from input to output.
  (define (transfer-body in out headers)
    (let ([content-length (get-content-length headers)])
      (debug "transfer-body: content-length: ~a" content-length)
      (if content-length
          (write-bytes (read-n-bytes in content-length) out)
          (let loop ()
            (let ([line (read-http-line in)])
              (cond
               [(eof-object? line) (void)]
               [(bytes=? line #"")
                (write-http-line out line)
                (void)]
               [else
                (write-http-line out line)
                (loop)])))))
    (flush-output (if (connection? out)
                      (connection-o-port out)
                      out)))

  )