Skip to content

core: optimize timers, conn handler and responses for throughput under high concurrency #94

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Merged
merged 14 commits into from
Jun 16, 2020
Merged

core: optimize timers, conn handler and responses for throughput under high concurrency #94

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
14 commits
Select commit Hold shift + click to select a range
1359f28
timer: improve performance
Bogdanp Jun 6, 2020
56cc017
response: improve performance of adding additl. headers to a resp
Bogdanp Jun 7, 2020
851ce73
response: improve performance of seconds->gmt-bytes
Bogdanp Jun 7, 2020
3b7abb4
response: add cprintf to replace fprintf where possible
Bogdanp Jun 7, 2020
a1c9080
handle-connection/cm: skip unnecessary peek for perf
Bogdanp Jun 7, 2020
ef5be94
ci: replace 7.5 with 7.7 in CI
Bogdanp Jun 7, 2020
2e7f981
response: clean up implementation of add-missing-headers
Bogdanp Jun 7, 2020
4419d17
timer: use thread mailbox for manager instead of async ch
Bogdanp Jun 14, 2020
9db5b8d
seconds->gmt-bytes: use an exact size buffer
Bogdanp Jun 14, 2020
caf42b0
cprintf: use regexp-split to parse fmt
Bogdanp Jun 14, 2020
4c30f11
output-file/boundary: only extract `out' in multi-boundary case
Bogdanp Jun 14, 2020
f1035e0
seconds->gmt-bytes: add output tests
Bogdanp Jun 14, 2020
530318e
seconds->gmt-bytes: fix off-by-one error in write-number!
Bogdanp Jun 14, 2020
dcc2647
test: add a couple more seconds->gmt-bytes cases
Bogdanp Jun 14, 2020
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
2 changes: 1 addition & 1 deletion .github/workflows/ci.yml
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -6,7 +6,7 @@ jobs:
runs-on: ubuntu-latest
strategy:
matrix:
racket-version: ["7.5", "7.6", "current"]
racket-version: ["7.6", "7.7", "current"]
racket-variant: ["regular", "CS"]
steps:
- uses: actions/checkout@master
Expand Down
279 changes: 171 additions & 108 deletions web-server-lib/web-server/http/response.rkt
View file
Open in desktop
Original file line number Diff line number Diff line change
@@ -1,18 +1,19 @@
#lang racket/base

(require racket/contract
file/md5
(require file/md5
racket/contract
racket/port
racket/list
racket/match
xml/xml
web-server/private/connection-manager
(submod web-server/private/connection-manager private)
web-server/http/request-structs
web-server/http/response-structs
web-server/private/util
syntax/parse/define
(for-syntax racket/base
racket/list
syntax/parse
syntax/parse/lib/function-header))

(provide
Expand All @@ -29,14 +30,13 @@
(define-simple-macro (define/ext (~and (name:id conn:id arg:formal ...) fun-header)
body:expr ...+)
(define fun-header
(with-handlers ([exn:fail? (λ (e)
(kill-connection! conn)
(raise e))])
(with-handlers ([exn:fail?
(λ (e)
(kill-connection! conn)
(raise e))])
body ...
(flush-output (connection-o-port conn)))))



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

Expand All @@ -54,65 +54,85 @@
(output-response-body conn resp))]
;; Otherwise, use chunked encoding
[else
(output-response-head conn resp
(list (header #"Transfer-Encoding" #"chunked")))
(output-response-head conn resp #t)
(output-response-body/chunked 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-header h k v)
(if (hash-has-key? h k)
empty
(list (header k v))))
(define-syntax-rule (maybe-headers h [k v] ...)
(append (maybe-header h k v)
...))

(define (output-response-head conn bresp [more-hs empty])
(fprintf (connection-o-port conn)
"HTTP/1.1 ~a ~a\r\n"
(response-code bresp)
(response-message bresp))
(define hs (append (response-headers bresp) more-hs))
(define seen? (make-hash))
(for ([h (in-list hs)])
(hash-set! seen? (header-field h) #t))
(output-headers
conn
(append
(maybe-headers
seen?
[#"Date"
(string->bytes/utf-8 (seconds->gmt-string (current-seconds)))]
[#"Last-Modified"
(string->bytes/utf-8 (seconds->gmt-string (response-seconds bresp)))]
[#"Server"
#"Racket"])
(if (response-mime bresp)
(maybe-headers
seen?
[#"Content-Type"
(response-mime bresp)])
empty)
(if (connection-close? conn)
(maybe-headers
seen?
[#"Connection" #"close"])
empty)
hs)))
(define-syntax (add-missing-headers stx)
Copy link
Member

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Is this mostly used with empty initial headers? I think that case could be optimized to not do any of the checking here.

Copy link
Contributor Author

@Bogdanp Bogdanp Jun 14, 2020 •
edited
Loading

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

It's used to add the headers iff they don't exist so I think the checking is necessary since an app could provide its own versions of these headers.

(syntax-parse stx
[(_ hs:expr [name:bytes value:expr] ...+)
#'(let ([res hs])
(define to-add
(for/fold ([to-add (list name ...)])
([h (in-list hs)])
(remove (header-field h) to-add bytes-ci=?)))
(let ([value-e value])
(when (and value-e (member name to-add bytes-ci=?))
(set! res (cons (header name value-e) res)))) ...
res)]))

;; Compile-time fprintf specialized to byte strings.
(define-syntax (cprintf stx)
(define (parse-fmt bs)
(filter-not
(lambda (sub)
(equal? sub #""))
(add-between (regexp-split #rx#"~a" bs) 'arg)))

(syntax-parse stx
[(_ fmt:bytes arg-e:expr ...)
#'(cprintf (current-output-port) fmt arg-e ...)]

[(_ out-e:expr fmt:bytes arg-e:expr ...)
#:with out-id (datum->syntax #'out-e 'out)
#:with (write-e ...) (for/fold ([exprs null]
[args (syntax-e #'(arg-e ...))]
#:result (reverse exprs))
([chunk (in-list (parse-fmt (syntax->datum #'fmt)))])
(if (eq? chunk 'arg)
(values
(cons #`(display #,(car args) out-id) exprs)
(cdr args))
(values
(cons #`(write-bytes #,(datum->syntax #'fmt chunk) out-id) exprs)
args)))
#'(let ([out-id out-e])
write-e ...)]))

(define (output-response-head conn bresp [chunked? #f])
(cprintf
(connection-o-port conn)
#"HTTP/1.1 ~a ~a\r\n"
(response-code bresp)
(response-message bresp))

(define hs
(add-missing-headers
(response-headers bresp)
[#"Connection" (and (connection-close? conn) #"close")]
[#"Content-Type" (response-mime bresp)]
[#"Date" (seconds->gmt-bytes (current-seconds))]
[#"Last-Modified" (seconds->gmt-bytes (response-seconds bresp))]
[#"Server" #"Racket"]
[#"Transfer-Encoding" (and chunked? #"chunked")]))

(output-headers conn 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"))
(define (print-headers out hs)
(for ([h (in-list hs)])
(cprintf
out
#"~a: ~a\r\n"
(header-field h)
(header-value h)))
(write-bytes #"\r\n" out))

; RFC 2616 Section 4.4
(define (terminated-response? r)
Expand Down Expand Up @@ -159,8 +179,9 @@
;; The client might go away while the response is being generated,
;; in which case the output port will be closed so we have to
;; gracefully back out when that happens.
(with-handlers ([exn:fail? (lambda (e)
(kill-thread to-chunker-t))])
(with-handlers ([exn:fail?
(lambda (_)
(kill-thread to-chunker-t))])
(define buffer (make-bytes 16384))
(let loop ()
(define bytes-read-or-eof
Expand All @@ -170,42 +191,80 @@
;; a responder can run indefinitely as long as it writes
;; *something* every (current-send-timeout) seconds.
(reset-connection-response-send-timeout! conn)
(fprintf to-client "~a\r\n" (number->string bytes-read-or-eof 16))
(cprintf to-client #"~a\r\n" (number->string bytes-read-or-eof 16))
Copy link
Member

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

I wonder if a number->bytes function would be useful

Copy link
Contributor Author

@Bogdanp Bogdanp Jun 14, 2020 •
edited
Loading

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

In the standard library? I think it would be. I feel like I've had to write something like it in a few libraries.

(write-bytes buffer to-client 0 bytes-read-or-eof)
(fprintf to-client "\r\n")
(write-bytes #"\r\n" to-client)
(flush-output to-client)
(loop)))
(thread-wait to-chunker-t)
(fprintf to-client "0\r\n")
(fprintf to-client "\r\n")
(write-bytes #"0\r\n\r\n" to-client)
(flush-output to-client)))

; seconds->gmt-string : Nat -> String
; seconds->gmt-bytes : exact-integer -> bytes
; format is rfc1123 compliant according to rfc2068 (http/1.1)
(define (seconds->gmt-bytes s)
(define d (seconds->date s #f))
(define t (make-bytes 29 32)) ;; #\space = 32
(begin0 t
(write-week-day! t (date-week-day d))
(write-zero-padded! t 5 (date-day d))
(write-month! t (date-month d))
(write-number! t 15 (date-year d))
(write-zero-padded! t 17 (date-hour d))
(bytes-set! t 19 58) ;; #\:
(write-zero-padded! t 20 (date-minute d))
(bytes-set! t 22 58) ;; #\:
(write-zero-padded! t 23 (date-second d))
(bytes-copy! t 26 #"GMT")))

(module+ testing
(provide seconds->gmt-string))
(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"))
(provide seconds->gmt-bytes))

(define-syntax-rule (write-zero-padded! dest dest-start e)
(let ([n e])
(cond
[(< n 10)
(bytes-set! dest dest-start 48) ;; #\0 = 48
(bytes-set! dest (add1 dest-start) (+ n 48))]

[else
(write-number! dest (add1 dest-start) n)])))

(define-syntax-rule (write-month! dest m)
(bytes-copy!
dest 8
(case m
[(1) #"Jan"]
[(2) #"Feb"]
[(3) #"Mar"]
[(4) #"Apr"]
[(5) #"May"]
[(6) #"Jun"]
[(7) #"Jul"]
[(8) #"Aug"]
[(9) #"Sep"]
[(10) #"Oct"]
[(11) #"Nov"]
[(12) #"Dev"])))

(define-syntax-rule (write-week-day! dest d)
(bytes-copy!
dest 0
(case d
[(0) #"Sun,"]
[(1) #"Mon,"]
[(2) #"Tue,"]
[(3) #"Wed,"]
[(4) #"Thu,"]
[(5) #"Fri,"]
[(6) #"Sat,"])))

(define-syntax-rule (write-number! dest dest-end num)
(let loop ([k dest-end] [n num])
(define d (remainder n 10))
(bytes-set! dest k (+ d 48)) ;; #\0
(when (>= n 10)
(loop (sub1 k) (quotient n 10)))))


;; output-file: connection
Expand Down Expand Up @@ -315,28 +374,32 @@
(network-error 'output-file "~a" (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))]))))))))))
(cond
; Single ranges (in 200 or 206 responses) are sent straight out
; in their simplest form:
[(= (length converted-ranges) 1)
(output-file-range conn input (caar converted-ranges) (cdar converted-ranges))]

; Multiple ranges are encoded as multipart/byteranges:
[else
(define out (connection-o-port conn))
(let loop ([ranges converted-ranges]
[multipart-headers multipart-headers])
(match ranges
[(list)
; Final boundary (must start on new line; ends with a new line)
(cprintf out #"--~a--\r\n" boundary)
(void)]
[(list-rest (list-rest start end) rest)
; Intermediate boundary (must start on new line; ends with a new line)
(cprintf out #"--~a\r\n" boundary)
; Headers and new line
(display (car multipart-headers) out)
; Content
(output-file-range conn input start end)
; Newline before next field
(write-bytes #"\r\n" out)
(loop rest (cdr multipart-headers))]))]))))))))

;; prerender-multipart/byteranges-headers : bytes (alist-of integer integer) integer -> (list-of bytes)
(define (prerender-multipart/byteranges-headers maybe-mime-type converted-ranges total-file-length)
Expand Down
Loading