379 lines
15 KiB
Racket
379 lines
15 KiB
Racket
#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
|
|
[print-headers (output-port? (listof header?) . -> . void)]
|
|
[rename ext:output-response output-response (connection? response? . -> . void)]
|
|
[rename ext:output-response/method output-response/method (connection? response? bytes? . -> . void)]
|
|
[rename ext:output-file output-file (connection? path-string? bytes? bytes? (or/c pair? false/c) . -> . void)])
|
|
|
|
(define (output-response conn resp)
|
|
(output-response/method conn resp #"GET"))
|
|
|
|
(define (output-response/method conn resp meth)
|
|
; XXX Use chunked encoding for non-terminated responses
|
|
(unless (terminated-response? resp)
|
|
(set-connection-close?! conn #t))
|
|
(output-response-head conn resp)
|
|
(unless (bytes-ci=? meth #"HEAD")
|
|
(output-response-body conn resp)))
|
|
|
|
;; 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-syntax-rule (maybe-hash-set! h k v)
|
|
(unless (hash-has-key? h k)
|
|
(hash-set! h k (header k v))))
|
|
(define-syntax-rule (maybe-hash-set!* h [k v] ...)
|
|
(begin (maybe-hash-set! h k v)
|
|
...))
|
|
|
|
(define (output-response-head conn bresp)
|
|
(fprintf (connection-o-port conn)
|
|
"HTTP/1.1 ~a ~a\r\n"
|
|
(response-code bresp)
|
|
(response-message bresp))
|
|
(define hs (make-hash))
|
|
(for ([h (in-list (response-headers bresp))])
|
|
(hash-set! hs (header-field h) h))
|
|
(maybe-hash-set!*
|
|
hs
|
|
[#"Date"
|
|
(string->bytes/utf-8 (seconds->gmt-string (current-seconds)))]
|
|
[#"Last-Modified"
|
|
(string->bytes/utf-8 (seconds->gmt-string (response-seconds bresp)))]
|
|
[#"Server"
|
|
#"Racket"]
|
|
[#"Content-Type"
|
|
(response-mime bresp)])
|
|
(when (connection-close? conn)
|
|
(hash-set! hs #"Connection"
|
|
(make-header #"Connection" #"close")))
|
|
(output-headers
|
|
conn
|
|
(hash-values hs)))
|
|
|
|
;; 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"))
|
|
|
|
; RFC 2616 Section 4.4
|
|
(define (terminated-response? r)
|
|
(define hs (response-headers r))
|
|
(or (headers-assq* #"Content-Length" hs)
|
|
(cond
|
|
[(headers-assq* #"Transfer-Encoding" hs)
|
|
=> (λ (h) (not (bytes=? (header-value h) #"identity")))]
|
|
[else #f])))
|
|
|
|
(define (output-response-body conn bresp)
|
|
(define o-port (connection-o-port conn))
|
|
((response-output bresp) o-port)
|
|
(flush-output o-port))
|
|
|
|
; 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)))])
|
|
(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-response-head
|
|
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-response-head
|
|
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)])
|
|
(response
|
|
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))
|
|
void))
|
|
(response
|
|
206 #"Partial content"
|
|
modified-seconds
|
|
(bytes-append #"multipart/byteranges; boundary=" boundary)
|
|
(list (make-header #"Accept-Ranges" #"bytes")
|
|
(make-content-length-header total-content-length))
|
|
void)))
|
|
|
|
;; make-200-response : integer bytes integer -> basic-response
|
|
(define (make-200-response modified-seconds mime-type total-content-length)
|
|
(response
|
|
200 #"OK"
|
|
modified-seconds
|
|
mime-type
|
|
(list (make-header #"Accept-Ranges" #"bytes")
|
|
(make-content-length-header total-content-length))
|
|
void))
|
|
|
|
;; make-416-response : integer bytes -> basic-response
|
|
(define (make-416-response modified-seconds mime-type)
|
|
(response
|
|
416 #"Invalid range request"
|
|
modified-seconds
|
|
mime-type
|
|
null
|
|
void))
|
|
|
|
;; 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))
|