#lang racket/base
(require racket/contract
         file/md5
         racket/port
         racket/list
         racket/match
         (only-in srfi/1/list fold)
         (only-in srfi/13/string string-join)
         xml/xml
         web-server/private/connection-manager
         web-server/http/request-structs
         web-server/http/response-structs
         web-server/private/util)

(provide/contract
 [rename ext:output-response output-response (connection? response/c . -> . void)]
 [rename ext:output-response/method output-response/method (connection? response/c bytes? . -> . void)]
 [rename ext:output-file output-file (connection? path-string? bytes? bytes? (or/c pair? false/c) . -> . void)])

;; Table 1. head responses:
; ------------------------------------------------------------------------------
; |method | close? | x-fer coding || response actions
; |-----------------------------------------------------------------------------
; |-----------------------------------------------------------------------------
; |head   |   #t   | chunked      || 1. Output the headers only.
; |-------------------------------|| 2. Add the special connection-close header.
; |head   |   #t   | not-chunked  ||
; |-----------------------------------------------------------------------------
; |head   |   #f   | chunked      || 1. Output the headers only.
; |-------------------------------|| 2. Don't add the connection-close header.
; |head   |   #f   | not-chunked  ||
; |-----------------------------------------------------------------------------

;; Table 2. get responses:
; ------------------------------------------------------------------------------
; |method | x-fer-coding | close? || response actions
; |-----------------------------------------------------------------------------
; |-----------------------------------------------------------------------------
; | get   | chunked      |   #t   || 1. Output headers as above.
; |       |              |        || 2. Generate trivial chunked response.
; |-----------------------------------------------------------------------------
; | get   | chunked      |   #f   || 1. Output headers as above.
; |       |              |        || 2. Generate chunks as per RFC 2616 sec. 3.6
; |-----------------------------------------------------------------------------
; | get   | not chunked  |   #t   || 1. Output headers as above.
; |-------------------------------|| 2. Generate usual non-chunked response.
; | get   | not chunked  |   #f   ||
; |-----------------------------------------------------------------------------

;; Notes:
;; 1. close? is a boolean which corresponds roughly to the protocol version.
;;    #t |-> 1.0 and #f |-> 1.1. See function close-connection?
;;
;; 2. In the case of a chunked response when close? = #f, then the response
;;    must be compliant with http 1.0. In this case the chunked response is
;;    simply turned into a non-chunked one.

(define (output-response conn resp)
  (output-response/method conn resp #"GET"))

(define (output-response/method conn resp meth)
  (define bresp (normalize-response resp (connection-close? conn)))
  (output-headers+response/basic conn bresp)
  (unless (bytes-ci=? meth #"HEAD")
    (output-response/basic conn bresp)))

;; Write the headers portion of a response to an output port.
;; NOTE: According to RFC 2145 the server should write HTTP/1.1
;;       header for *all* clients.
(define (output-headers+response/basic conn bresp)
  (fprintf (connection-o-port conn)
           "HTTP/1.1 ~a ~a\r\n"
           (response/basic-code bresp)
           (response/basic-message bresp))
  (output-headers
   conn 
   (list* (make-header #"Date" (string->bytes/utf-8 (seconds->gmt-string (current-seconds))))
          (make-header #"Last-Modified" (string->bytes/utf-8 (seconds->gmt-string (response/basic-seconds bresp))))
          (make-header #"Server" #"Racket")
          (make-header #"Content-Type" (response/basic-mime bresp))
          (append (if (connection-close? conn)
                      (list (make-header #"Connection" #"close"))
                      empty)
                  (response/basic-headers bresp)))))

;; output-headers : connection (list-of header) -> void
(define (output-headers conn headers)
  (print-headers (connection-o-port conn) headers))

;; print-headers : output-port (list-of header) -> void
(define (print-headers out headers)
  (for-each (match-lambda
              [(struct header (field value))
               (fprintf out "~a: ~a\r\n" field value)])
            headers)
  (fprintf out "\r\n"))

(define (output-response/basic conn bresp)
  (define o-port (connection-o-port conn))
  (match bresp
    [(? response/full?)
     (for-each
      (lambda (str) (display str o-port))
      (response/full-body bresp))]
    [(? response/incremental?)
     (if (connection-close? conn)
         ((response/incremental-generator bresp)
          (lambda chunks
            (for-each (lambda (chunk) (display chunk o-port)) chunks)))
         (begin
           ((response/incremental-generator bresp)
            (lambda chunks
              (define length (apply + 0 (map bytes-length chunks)))
              (if (zero? length)
                  (flush-output o-port)
                  (begin
                    (fprintf o-port "~x\r\n" length)                  
                    (for-each (lambda (chunk) (display chunk o-port)) chunks)
                    (fprintf o-port "\r\n")))))
           ; one \r\n ends the last (empty) chunk and the second \r\n ends the (non-existant) trailers
           (fprintf o-port "0\r\n\r\n")))]))

; seconds->gmt-string : Nat -> String
; format is rfc1123 compliant according to rfc2068 (http/1.1)
(define (seconds->gmt-string s)
  (let* ([local-date (seconds->date s)]
         [date (seconds->date (- s
                                 (date-time-zone-offset local-date)
                                 (if (date-dst? local-date) 3600 0)))])
    (format "~a, ~a ~a ~a ~a:~a:~a GMT"
            (vector-ref DAYS (date-week-day date))
            (two-digits (date-day date))
            (vector-ref MONTHS (sub1 (date-month date)))
            (date-year date)
            (two-digits (date-hour date))
            (two-digits (date-minute date))
            (two-digits (date-second date)))))

; two-digits : num -> str
(define (two-digits n)
  (let ([str (number->string n)])
    (if (< n 10) (string-append "0" str) str)))

(define MONTHS
  #("Jan" "Feb" "Mar" "Apr" "May" "Jun" "Jul" "Aug" "Sep" "Oct" "Nov" "Dec"))

(define DAYS
  #("Sun" "Mon" "Tue" "Wed" "Thu" "Fri" "Sat"))

(define (ext:wrap f)
  (lambda (conn . args)
    (with-handlers ([exn:fail? (lambda (exn)
                            (kill-connection! conn)
                            (raise exn))])
      (apply f conn args)
      (flush-output (connection-o-port conn)))))

(define ext:output-response
  (ext:wrap output-response))

;; output-file: connection
;;              path
;;              symbol
;;              bytes
;;              (U (listof (U byte-range-spec suffix-byte-range-spec)) #f)
;;           -> void
;;
;; Ranges is #f if the client did not specify a Range header, or:
;;
;;     (list-of (U byte-range-spec suffix-byte-range-spec))
;;
;; where:
;;
;;     byte-range-spec : (cons integer (U integer #f))
;;     suffix-byte-range-spec : (cons #f integer)
;;
;; as described in the comments in dispatchers/dispatch-files.
;;
;; A boundary is generated only if a multipart/byteranges response needs
;; to be generated (i.e. if a Ranges header was specified with more than
;; one range in it).
(define (output-file conn file-path method mime-type ranges)
  (output-file/boundary
   conn
   file-path
   method
   mime-type
   ranges
   (if (and ranges (> (length ranges) 1))
       (md5 (string->bytes/utf-8 (number->string (current-inexact-milliseconds))))
       #f)))

;; output-file: connection
;;              path
;;              symbol
;;              bytes
;;              (U (listof (U byte-range-spec suffix-byte-range-spec)) #f)
;;              (U bytes #f)
;;           -> void
(define (output-file/boundary conn file-path method mime-type ranges boundary)
  ; total-file-length : integer
  (define total-file-length
    (file-size file-path))
  ; modified-seconds : integer
  (define modified-seconds
    (file-or-directory-modify-seconds file-path))
  ; boundary-length : (U integer #f)
  (define boundary-length
    (if boundary
        (bytes-length boundary)
        #f))
  ; If convert-http-ranges fails, send a 416 bad range resposne:
  (with-handlers ([exn:fail?
                   (lambda (exn)
                     (fprintf (current-error-port)
                              (exn-message exn))
                     (output-headers+response/basic
                      conn
                      (make-416-response modified-seconds mime-type)))])
    (let* (; converted-ranges : (alist-of integer integer)
           ; This is a list of actual start and end offsets in the file. 
           ; See the comments for convert-http-ranges for more information.
           [converted-ranges
            (if ranges
                (convert-http-ranges ranges total-file-length)
                (list (cons 0 total-file-length)))]
           ; multipart-headers : (list-of bytes)
           ; This is a list of header blocks to prepend to each range being sent.
           ; The idea is so we can calculate an overall content-length for the
           ; response. This *must be* the same length as converted-ranges.
           [multipart-headers
            (if (> (length converted-ranges) 1)
                (prerender-multipart/byteranges-headers mime-type converted-ranges total-file-length)
                (list #""))]
           ; total-content-length : integer
           [total-content-length
            (if (= (length converted-ranges) 1)
                ; One range: content-length is the length of the range being sent:
                (- (cdar converted-ranges) (caar converted-ranges))
                ; Multiple ranges: content-length is the length of the multipart,
                ; including content, headers and boundaries:
                (fold (lambda (range headers accum)
                        (+ accum                       ; length so far
                           (bytes-length headers)      ; length of the headers and header newlinw
                           (- (cdr range) (car range)) ; length of the content
                           2))                         ; length of the content newline
                      (+ (* (+ boundary-length 4) 
                            (length converted-ranges)) ; length of the intermediate boundaries
                         (+ boundary-length 6))        ; length of the final boundary
                      converted-ranges
                      multipart-headers))])
      ; Send a 206 iff ranges were specified in the request:
      (output-headers+response/basic
       conn
       (if ranges
           (make-206-response modified-seconds mime-type total-content-length total-file-length converted-ranges boundary)
           (make-200-response modified-seconds mime-type total-content-length)))
      ; Send the appropriate file content:
      (when (bytes-ci=? method #"GET")
        (adjust-connection-timeout! ; Give it one second per byte.
         conn
         (apply + (map (lambda (range)
                         (- (cdr range) (car range)))
                       converted-ranges)))
        (with-handlers ([exn:fail? (lambda (exn) (network-error 'output-file (exn-message exn)))])
          (call-with-input-file file-path
            (lambda (input)
              (if (= (length converted-ranges) 1)
                  ; Single ranges (in 200 or 206 responses) are sent straight out
                  ; in their simplest form:
                  (output-file-range conn input (caar converted-ranges) (cdar converted-ranges))
                  ; Multiple ranges are encoded as multipart/byteranges:
                  (let loop ([ranges converted-ranges] [multipart-headers multipart-headers])
                    (match ranges
                      [(list) 
                       ; Final boundary (must start on new line; ends with a new line)
                       (fprintf (connection-o-port conn) "--~a--\r\n" boundary)
                       (void)]
                      [(list-rest (list-rest start end) rest)
                       ; Intermediate boundary (must start on new line; ends with a new line)
                       (fprintf (connection-o-port conn) "--~a\r\n" boundary)
                       ; Headers and new line
                       (display (car multipart-headers) (connection-o-port conn))
                       ; Content
                       (output-file-range conn input start end)
                       ; Newline before next field
                       (fprintf (connection-o-port conn) "\r\n")
                       (loop rest (cdr multipart-headers))]))))))))))

;; prerender-multipart/byteranges-headers : bytes (alist-of integer integer) integer -> (list-of bytes)
(define (prerender-multipart/byteranges-headers mime-type converted-ranges total-file-length)
  (map (lambda (range)
         (match range
           [(list-rest start end)
            (let ([out (open-output-bytes)])
              (print-headers out (list (make-header #"Content-Type" mime-type)
                                       (make-content-range-header start end total-file-length)))
              (begin0 (get-output-bytes out)
                      (close-output-port out)))]))
       converted-ranges))

;; output-file-range : connection file-input-port integer integer -> void
;;
;; start must be inclusive; end must be exclusive.
(define (output-file-range conn input start end)
  (file-position input start)
  (let ([limited-input (make-limited-input-port input (- end start) #f)])
    (copy-port limited-input (connection-o-port conn))
    (close-input-port limited-input)))

;; convert-http-ranges : (alist-of (U integer #f) (U integer #f))
;;                       integer
;;                    -> (alist-of integer integer)
;;
;; Converts a list of HTTP ranges:
;;
;; into pairs of offsets we can use to read from a file:
;; 
;;   - suffix-byte-range-specs are converted to pairs of absolute offsets;
;;   - missing end offsets in byte-range-specs ranges are filled in;
;;   - end offsets are exclusive (as opposed to the inclusive offsets in ranges and the HTTP spec).
;;
;; The HTTP spec recommends that ranges are sent in the order they are specified in the request.
(define (convert-http-ranges ranges total-file-length)
  (define converted
    (filter-map (lambda (range)
                  ; a : (U integer #f)
                  ; b : (U integer #f)
                  ; The original values quoted in the Range header:
                  (define-values (a b)
                    (values (car range)
                            (cdr range)))
                  ; a* : integer
                  ; b* : integer
                  ; Convert inclusive end offsets and suffix ranges:
                  (define-values (a* b*)
                    (cond [(not a) (values (- total-file-length b) total-file-length)]
                          [(not b) (values a total-file-length)]
                          [else    (values a (add1 b))]))
                  ; a** : integer
                  ; b** : integer
                  ; Trim to the size of the file:
                  (define-values (a** b**)
                    (values (max 0 (min total-file-length a*))
                            (max 0 (min total-file-length b*))))
                  ; Get rid of zero-length ranges (including ones that are outside the file length):
                  (if (< a** b**)
                      (cons a** b**)
                      #f))
                ranges))
  (if (null? converted)
      (error (format "No satisfiable ranges in ~a/~a." ranges total-file-length))
      converted))

;; make-206-response : integer bytes integer integer (alist-of integer integer) bytes -> basic-response
(define (make-206-response modified-seconds mime-type total-content-length total-file-length converted-ranges boundary)
  (if (= (length converted-ranges) 1)
      (let ([start (caar converted-ranges)]
            [end   (cdar converted-ranges)])
        (make-response/basic
         206 #"Partial content"
         modified-seconds
         mime-type 
         (list (make-header #"Accept-Ranges" #"bytes")
               (make-content-length-header total-content-length)
               (make-content-range-header start end total-file-length))))
      (make-response/basic
       206 #"Partial content"
       modified-seconds
       (bytes-append #"multipart/byteranges; boundary=" boundary)
       (list (make-header #"Accept-Ranges" #"bytes")
             (make-content-length-header total-content-length)))))

;; make-200-response : integer bytes integer -> basic-response
(define (make-200-response modified-seconds mime-type total-content-length)
  (make-response/basic
   200 #"OK"
   modified-seconds
   mime-type 
   (list (make-header #"Accept-Ranges" #"bytes")
         (make-content-length-header total-content-length))))

;; make-416-response : integer bytes -> basic-response
(define (make-416-response modified-seconds mime-type)
  (make-response/basic
   416 #"Invalid range request"
   modified-seconds
   mime-type 
   null))

;; make-content-length-header : integer -> header
(define (make-content-length-header total-content-length)
  (make-header #"Content-Length" (string->bytes/utf-8 (number->string total-content-length))))

;; make-content-range-header : integer integer integer -> header
;; start must be inclusive; end must be exclusive.
(define (make-content-range-header start end total-file-length)
  (make-header #"Content-Range" 
               (string->bytes/utf-8
                (format "bytes ~a-~a/~a" start (sub1 end) total-file-length))))

(define ext:output-file
  (ext:wrap output-file))

(define ext:output-response/method
  (ext:wrap output-response/method))
