Many improvements to drivers/http.rkt
This commit is contained in:
parent
bd973f069a
commit
c538c577c3
|
|
@ -110,18 +110,26 @@
|
|||
(turn! facet
|
||||
(lambda ()
|
||||
(react
|
||||
(local-connection-protocol ds connection-name conn routes req)
|
||||
(local-connection-protocol ds connection-name conn port routes req)
|
||||
(on-stop (async-channel-put continue-ch 'dummy)))))
|
||||
(async-channel-get continue-ch)
|
||||
(unless close? (process-requests)))))))
|
||||
|
||||
(define next-request-id (inexact->exact (floor (current-inexact-milliseconds))))
|
||||
|
||||
(define (local-connection-protocol ds connection-name conn routes req)
|
||||
(define (local-connection-protocol ds connection-name conn port routes req)
|
||||
(let/ec return
|
||||
|
||||
(define reply-sent? #f)
|
||||
(define (unless-reply-sent thunk)
|
||||
(unless reply-sent?
|
||||
(set! reply-sent? #t)
|
||||
(thunk)))
|
||||
|
||||
(define (respond! resp)
|
||||
(output-response/method conn resp (request-method req))
|
||||
(unless-reply-sent
|
||||
(lambda ()
|
||||
(output-response/method conn resp (request-method req))))
|
||||
(stop-current-facet))
|
||||
|
||||
(define (decode-bytes bs)
|
||||
|
|
@ -148,10 +156,11 @@
|
|||
(define headers (headers-map (request-headers/raw req)))
|
||||
|
||||
(define host-and-port (cond [(assq 'host (request-headers req)) => cdr] [else #f]))
|
||||
(define-values (host port)
|
||||
(define host
|
||||
(match host-and-port
|
||||
[(regexp #px"(.*):(\\d+)" (list _ host port)) (values host (string->number port))]
|
||||
[host (values host 80)]))
|
||||
[#f (RequestHost-absent)]
|
||||
[(regexp #px"(.*):\\d+" (list _ host)) (RequestHost-present host)]
|
||||
[host (RequestHost-present host)]))
|
||||
|
||||
(define method (lowercase-symbol! (decode-bytes (request-method req))))
|
||||
|
||||
|
|
@ -198,76 +207,74 @@
|
|||
(list)))
|
||||
(return (void)))))
|
||||
(match-define (active-handler handler handler-terminated?) (set-first handler-set))
|
||||
(define processing #f)
|
||||
(define pending-code 500)
|
||||
(define pending-message "Internal Server Error")
|
||||
(define pending-code 200)
|
||||
(define pending-message "OK")
|
||||
(define pending-headers-rev '())
|
||||
(define chunk-ch #f)
|
||||
|
||||
(define (check-processing!)
|
||||
(unless processing
|
||||
(error 'HttpResponse "Attempt to reply before <processing> has been asserted")))
|
||||
|
||||
(define (send-headers!)
|
||||
(define (start-chunked-response!)
|
||||
(unless chunk-ch
|
||||
(set! chunk-ch (make-async-channel))
|
||||
(thread
|
||||
(lambda ()
|
||||
(output-response/method conn
|
||||
(response pending-code
|
||||
(string->bytes/utf-8 pending-message)
|
||||
(current-seconds)
|
||||
#f
|
||||
(build-headers (reverse pending-headers-rev))
|
||||
(lambda (output-port)
|
||||
(let loop ()
|
||||
(match (async-channel-get chunk-ch)
|
||||
[#f (void)]
|
||||
[bs
|
||||
(write-bytes bs output-port)
|
||||
(flush-output output-port)
|
||||
(loop)]))))
|
||||
(request-method req))))))
|
||||
(unless-reply-sent
|
||||
(lambda ()
|
||||
(output-response/method conn
|
||||
(response pending-code
|
||||
(string->bytes/utf-8 pending-message)
|
||||
(current-seconds)
|
||||
#f
|
||||
(build-headers (reverse pending-headers-rev))
|
||||
(lambda (output-port)
|
||||
(let loop ()
|
||||
(match (async-channel-get chunk-ch)
|
||||
[#f (void)]
|
||||
[bs
|
||||
(write-bytes bs output-port)
|
||||
(flush-output output-port)
|
||||
(loop)]))))
|
||||
(request-method req))))))))
|
||||
|
||||
(define (finish-request!)
|
||||
(send-headers!)
|
||||
(async-channel-put chunk-ch #f)
|
||||
(stop-current-facet))
|
||||
(define (send-final-chunk! chunk)
|
||||
(define bs (chunk->bytes chunk))
|
||||
(if chunk-ch
|
||||
(begin (async-channel-put chunk-ch bs)
|
||||
(async-channel-put chunk-ch #f)
|
||||
(stop-current-facet))
|
||||
(respond! (response/full pending-code
|
||||
(string->bytes/utf-8 pending-message)
|
||||
(current-seconds)
|
||||
#f
|
||||
(build-headers (reverse pending-headers-rev))
|
||||
(list bs)))))
|
||||
|
||||
(begin/dataflow
|
||||
(when (handler-terminated?)
|
||||
(finish-request!)))
|
||||
(set! pending-code 500)
|
||||
(set! pending-message "Internal Server Error")
|
||||
(set! pending-headers-rev '())
|
||||
(send-final-chunk! *empty-chunk*)))
|
||||
|
||||
(define res (object #:name connection-name
|
||||
[#:asserted (HttpResponse-processing)
|
||||
(log-syndicate/drivers/http-debug "~v: +processing" connection-name)
|
||||
(set! processing #t)
|
||||
(set! pending-code 200)
|
||||
(set! pending-message "OK")
|
||||
#:retracted
|
||||
(log-syndicate/drivers/http-debug "~v: -processing" connection-name)
|
||||
(finish-request!)]
|
||||
[#:message (HttpResponse-status code message)
|
||||
(log-syndicate/drivers/http-debug "~v: status ~v ~v" connection-name
|
||||
code message)
|
||||
(check-processing!)
|
||||
(set! pending-code code)
|
||||
(set! pending-message message)]
|
||||
[#:message (HttpResponse-header name value)
|
||||
(log-syndicate/drivers/http-debug "~v: header ~v ~v" connection-name
|
||||
name value)
|
||||
(check-processing!)
|
||||
(set! pending-headers-rev (cons (cons name value) pending-headers-rev))]
|
||||
[#:message (HttpResponse-body chunk)
|
||||
(log-syndicate/drivers/http-debug "~v: chunk ~v" connection-name
|
||||
chunk)
|
||||
(check-processing!)
|
||||
(send-headers!)
|
||||
(async-channel-put chunk-ch (chunk->bytes chunk))]))
|
||||
[#:message (HttpResponse-chunk chunk)
|
||||
(start-chunked-response!)
|
||||
(async-channel-put chunk-ch (chunk->bytes chunk))]
|
||||
[#:message (HttpResponse-done chunk)
|
||||
(send-final-chunk! chunk)]))
|
||||
(at handler (assert (HttpContext decoded-req res)))
|
||||
(return (void)))))
|
||||
|
||||
(begin (try-hostname host)
|
||||
(begin (when (RequestHost-present? host)
|
||||
(try-hostname (RequestHost-present-value host)))
|
||||
(try-hostname #f)
|
||||
(respond! (response/full 404
|
||||
#"Not Found"
|
||||
|
|
@ -285,6 +292,8 @@
|
|||
[[(cons expected pat) (cons actual p)] #:when (equal? expected actual) (loop pat p)]
|
||||
[[_ _] #f])))
|
||||
|
||||
(define *empty-chunk* (Chunk-bytes #""))
|
||||
|
||||
(define (chunk->bytes c)
|
||||
(match c
|
||||
[(Chunk-string s) (string->bytes/utf-8 s)]
|
||||
|
|
@ -313,7 +322,6 @@
|
|||
(lambda () method)
|
||||
(lambda () (quote-path-pattern () (path-pattern-element ...)))
|
||||
(lambda (req res)
|
||||
(at res (assert (HttpResponse-processing)))
|
||||
(match (HttpRequest-path req)
|
||||
[#,(match-quote-path-pattern #'(path-pattern-element ...))
|
||||
(async (match (let () body ...)
|
||||
|
|
@ -381,6 +389,7 @@
|
|||
(define (send-http-response! res code message
|
||||
#:headers [headers '()]
|
||||
#:mime-type [mime-type #f]
|
||||
#:done? [done? #t]
|
||||
. chunks)
|
||||
(send! res (HttpResponse-status code message))
|
||||
(when mime-type
|
||||
|
|
@ -390,7 +399,11 @@
|
|||
(for [(header headers)]
|
||||
(match-define (cons name value) header)
|
||||
(send! res (HttpResponse-header name value)))
|
||||
(for [(chunk chunks)] (send! res (HttpResponse-body chunk))))
|
||||
(let loop ((chunks chunks))
|
||||
(match chunks
|
||||
['() (when done? (send! res (HttpResponse-done *empty-chunk*)))]
|
||||
[(list ch) (send! res ((if done? HttpResponse-done HttpResponse-chunk) ch))]
|
||||
[(cons ch more) (send! res (HttpResponse-chunk ch)) (loop more)])))
|
||||
|
||||
;;---------------------------------------------------------------------------
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue