#lang racket
(require net/url
         net/uri-codec
         unstable/contract
         web-server/private/util
         web-server/private/connection-manager
         web-server/http/request-structs)

(define read-request/c
  (connection? 
   tcp-listen-port?
   (input-port? . -> . (values string? string?))
   . -> .
   (values request? boolean?)))

(provide/contract
 [read-headers (-> input-port? (listof header?))]
 [rename make-ext:read-request make-read-request
         (->* () (#:connection-close? boolean?) read-request/c)]
 [rename ext:read-request read-request
         read-request/c])

;; **************************************************
;; read-request: connection number (input-port -> string string) -> request boolean?
;; read the request line, and the headers, determine if the connection should
;; be closed after servicing the request and build a request structure
(define ((make-read-request 
          #:connection-close? [connection-close? #f])
         conn host-port port-addresses)
  (define ip 
    (connection-i-port conn))
  (define-values (method uri major minor)
    (read-request-line ip))
  (define headers 
    (read-headers ip))
  (define _
    (match (headers-assq* #"Content-Length" headers)
      [(struct header (f v))
       ; Give it one second per byte (with 5 second minimum... a bit arbitrary)          
       (adjust-connection-timeout! conn (max 5 (string->number (bytes->string/utf-8 v))))]
      [#f
       (void)]))
  (define-values (host-ip client-ip)
    (port-addresses ip))
  (define-values (bindings/raw-promise raw-post-data)
    (read-bindings&post-data/raw conn method uri headers))
  (values
   (make-request method uri headers bindings/raw-promise raw-post-data
                 host-ip host-port client-ip)
   (or connection-close?
       (close-connection? headers major minor
                          client-ip host-ip))))

(define (make-ext:read-request 
         #:connection-close? [connection-close? #f])
  (define read-request 
    (make-read-request #:connection-close? connection-close?))
  (define (ext:read-request conn host-port port-addresses)
    (with-handlers ([exn:fail?
                     (lambda (exn)
                       (kill-connection! conn)
                       (raise exn))])
      (read-request conn host-port port-addresses)))
  ext:read-request)

(define ext:read-request (make-ext:read-request #:connection-close? #f))

;; **************************************************
;; close-connection?

; close-connection? : (listof (cons symbol bytes)) number number string string -> boolean
; determine if this connection should be closed after serving the response
(define close-connection? 
  (let ([rx (byte-regexp #"[cC][lL][oO][sS][eE]")])
    (lambda (headers major minor client-ip host-ip)
      (or (< major 1)
          (and (= major 1) (= minor 0))
          (match (headers-assq* #"Connection" headers)
            [(struct header (f v))
             (and (regexp-match rx v)
                  #t)]
            [#f
             #f])
          (msie-from-local-machine? headers client-ip host-ip)))))

; msie-from-local-machine? : table str str -> bool
; to work around a bug in MSIE for documents < 265 bytes when connecting from the local
; machine.  The server could pad the response as MSIIS does, but closing the connection works, too.
; We do not check for version numbers since IE 6 under windows is 5.2 under macosX
(define msie-from-local-machine?
  (let ([rx (byte-regexp #"MSIE")])
    (lambda (headers client-ip host-ip)
      (and (string=? host-ip client-ip)
           (match
               (or (headers-assq* #"HTTP_USER_AGENT" headers)
                   (headers-assq* #"User-Agent" headers))
             [(struct header (f v))
              (and (regexp-match rx v)
                   #t)]
             [#f
              #f])))))

;; **************************************************
;; read-request-line  
(define match-method
  (let ([rx (byte-regexp #"^([^ ]+) (.+) HTTP/([0-9]+)\\.([0-9]+)$")])
    (lambda (a) (regexp-match rx a))))

; read-request-line : iport -> bytes url number number
; to read in the first line of an http request, AKA the "request line"
; effect: in case of errors, complain [MF: where] and close the ports
(define (read-request-line ip)
  (define line (read-bytes-line ip 'any))
  (if (eof-object? line)
      (network-error 'read-request "http input closed abruptly")
      (cond
        [(match-method line)
         => (match-lambda
              [(list _ method url major minor)
               (values method
                       (string->url (bytes->string/utf-8 url))
                       (string->number (bytes->string/utf-8 major))
                       (string->number (bytes->string/utf-8 minor)))])]
        [else (network-error 'read-request "malformed request ~a" line)])))

;; **************************************************
;; read-headers  
(define match-colon
  (let ([rx (byte-regexp (bytes-append #"^([^:]*):[ " (bytes 9) #"]*(.*)"))])
    (lambda (a) (regexp-match rx a))))

; read-headers : iport -> (listof header?)
(define (read-headers in)
  (let read-header ()
    (define l (read-bytes-line in 'any))
    (cond
      [(eof-object? l) null]
      [(zero? (bytes-length l)) null]
      [(match-colon l) 
       => (match-lambda
            [(list _ field value)
             (list* (make-header field (read-one-head in value))
                    (read-header))])]
      [else (network-error 'read-headers "malformed header")])))

; read-one-head : iport bytes -> bytes
(define (read-one-head in rhs)
  (match (peek-byte in)
    [(or 32 9) ;(or (eq? c #\space) (eq? c #\tab))
     ; (read-bytes-line in 'any) can't return eof
     ; because we just checked with peek-char
     ; Spidey: FLOW
     (read-one-head in (bytes-append rhs (read-bytes-line in 'any)))]
    [_ rhs]))

;; **************************************************
;; read-bindings
(define INPUT-BUFFER-SIZE 4096)
(define (read-to-eof in)
  (define b (read-bytes INPUT-BUFFER-SIZE in))
  (if (eof-object? b)
      empty
      (list* b (read-to-eof in))))

(define FILE-FORM-REGEXP (byte-regexp #"multipart/form-data; *boundary=(.*)"))

;; read-bindings&post-data/raw: connection symbol url (listof header?) -> (values (or/c (listof binding?) string?) (or/c bytes? false/c?))
(define (read-bindings&post-data/raw conn meth uri headers)
  (cond
    [(bytes-ci=? #"GET" meth)
     (values (delay
               (filter (lambda (x) x)
                       (map (match-lambda
                              [(list-rest k v)
                               (if (and (symbol? k) (string? v))
                                   (make-binding:form (string->bytes/utf-8 (symbol->string k))
                                                      (string->bytes/utf-8 v))
                                   #f)])
                            (url-query uri))))
             #f)]
    [(bytes-ci=? #"POST" meth)
     (local
       [(define content-type (headers-assq* #"Content-Type" headers))
        (define in (connection-i-port conn))]
       (cond
         [(and content-type (regexp-match FILE-FORM-REGEXP (header-value content-type)))
          => (match-lambda
               [(list _ content-boundary)
                ; XXX This can't be delay because it reads from the port, which would otherwise be closed.
                ;     I think this is reasonable because the Content-Type said it would have this format
                (define bs
                  (map (match-lambda
                         [(struct mime-part (headers contents))
                          (define rhs (header-value (headers-assq* #"Content-Disposition" headers)))
                          (match (list (regexp-match #"filename=(\"([^\"]*)\"|([^ ;]*))" rhs)
                                       (regexp-match #"[^e]name=(\"([^\"]*)\"|([^ ;]*))" rhs))
                            [(list #f #f)
                             (network-error 'reading-bindings "Couldn't extract form field name for file upload")]
                            [(list #f (list _ _ f0 f1))
                             (make-binding:form (or f0 f1) (apply bytes-append contents))]
                            [(list (list _ _ f00 f01) (list _ _ f10 f11))
                             (make-binding:file (or f10 f11) (or f00 f01) headers (apply bytes-append contents))])])
                       (read-mime-multipart content-boundary in)))
                (values
                 (delay bs)
                 #f)])]
         [else        
          (match (headers-assq* #"Content-Length" headers)
            [(struct header (_ value))
             (cond
               [(string->number (bytes->string/utf-8 value))
                => (lambda (len) 
                     (let ([raw-bytes (read-bytes len in)])
                       (values (delay (parse-bindings raw-bytes)) raw-bytes)))]
               [else 
                (network-error 'read-bindings "Post request contained a non-numeric content-length")])]
            [#f
             (let ([raw-bytes (apply bytes-append (read-to-eof in))])
               (values (delay (parse-bindings raw-bytes)) raw-bytes))])]))]
    [(bytes-ci=? #"PUT" meth)
     (local
       [(define content-type (headers-assq* #"Content-Type" headers))
        (define in (connection-i-port conn))]
       (match (headers-assq* #"Content-Length" headers)
         [(struct header (_ value))
          (cond [(string->number (bytes->string/utf-8 value))
                 => (lambda (len)
                      (let ([raw-bytes (read-bytes len in)])
                        (values (delay empty) raw-bytes)))]
                [else
                 (network-error 'read-bindings "Put request contained a non-numeric content-length")])]
         [#f
          (let ([raw-bytes (apply bytes-append (read-to-eof in))])
            (values (delay empty) raw-bytes))]))]
    [meth
     (values (delay empty) #f)]))

;; parse-bindings : bytes? -> (listof binding?)
(define (parse-bindings raw)
  (define len (bytes-length raw))
  (let loop ([start 0])
    (let find= ([key-end start])
      (if (>= key-end len)
          empty
          (if (eq? (bytes-ref raw key-end) (char->integer #\=))
              (let find-amp ([amp-end (add1 key-end)])
                (if (or (= amp-end len) (eq? (bytes-ref raw amp-end) (char->integer #\&)))
                    (list* (make-binding:form
                            (string->bytes/utf-8
                             (form-urlencoded-decode
                              (bytes->string/utf-8
                               (subbytes raw start key-end))))
                            (string->bytes/utf-8
                             (form-urlencoded-decode
                              (bytes->string/utf-8
                               (subbytes raw (add1 key-end) amp-end)))))
                           (loop (add1 amp-end)))
                    (find-amp (add1 amp-end))))
              (find= (add1 key-end)))))))

;; **************************************************
;; read-mime-multipart

; mime-part : (listof header?) * (listof bytes?)
(define-struct mime-part (headers contents))
(define CR-NL #"\r\n")
(define (construct-mime-part headers body)
  (make-mime-part
   headers
   (match body
     [(list)
      (list)]
     [(list-rest fst rst)
      (list* fst
             (foldr (lambda (byt acc)
                      (list* CR-NL byt acc))
                    empty
                    rst))])))

; read-mime-multipart : bytes iport -> (listof part)
(define (read-mime-multipart boundary in)
  (define boundary-len (bytes-length boundary))
  (define start-boundary (bytes-append #"--" boundary))
  (define end-boundary (bytes-append start-boundary #"--"))
  (let skip-preamble ()
    (define line (read-bytes-line in 'return-linefeed))
    (cond
      [(eof-object? line)
       (network-error 'read-mime-multipart "Port prematurely closed.")]
      [(bytes=? line start-boundary)
       (let read-parts ()
         (define headers (read-headers in))
         (let read-mime-part-body 
           ([more-k (lambda (contents)
                      (list* (construct-mime-part
                              headers contents)
                             (read-parts)))]
            [end-k (lambda (contents)
                     (list (construct-mime-part
                            headers contents)))])
           (define line (read-bytes-line in 'return-linefeed))
           (cond
             [(eof-object? line)
              (network-error 'read-mime-multipart "Port prematurely closed.")]
             [(bytes=? line start-boundary)
              (more-k empty)]
             [(bytes=? line end-boundary)
              (end-k empty)]
             [else 
              (read-mime-part-body
               (lambda (x) (more-k (list* line x)))
               (lambda (x) (end-k (list* line x))))])))]
      [(bytes=? line end-boundary) null]
      [else (skip-preamble)])))
