diff --git a/knots/web-server.scm b/knots/web-server.scm index 4ab59e3..10845e6 100644 --- a/knots/web-server.scm +++ b/knots/web-server.scm @@ -42,6 +42,12 @@ make-chunked-output-port/knots + &request-body-ended-prematurely + request-body-ended-prematurely-error? + + request-body-port/knots + read-request-body/knots + default-exception-handler default-write-response-exception-handler @@ -85,6 +91,75 @@ KEEP-ALIVE? is true." (setvbuf ret 'block buffering) ret) +(define* (make-delimited-input-port port len fail + #:key (keep-alive? #t)) + "Return an input port that reads from PORT, and makes sure that +exactly LEN bytes are available from PORT. Closing the returned port +closes PORT, unless KEEP-ALIVE? is true." + (define bytes-read 0) + + (define (read! bv start count) + (let ((count (min count (- len bytes-read)))) + (let loop ((ret (get-bytevector-n! port bv start count))) + (cond ((eof-object? ret) + (if (= bytes-read len) + 0 ; EOF + (fail bytes-read))) + ((and (zero? ret) (> count 0)) + ;; Do not return zero since zero means EOF, so try again. + (loop (get-bytevector-n! port bv start count))) + (else + (set! bytes-read (+ bytes-read ret)) + ret))))) + + (define close + (and (not keep-alive?) + (lambda () + (close-port port)))) + + (make-custom-binary-input-port "delimited input port" read! #f #f close)) + +;; Chunked Responses +(define &request-body-ended-prematurely + (make-exception-type '&request-body-ended-prematurely + &external-error + '(bytes-read))) + +(define make-request-body-ended-prematurely-error + (record-constructor &request-body-ended-prematurely)) + +(define request-body-ended-prematurely-error? + (record-predicate &request-body-ended-prematurely)) + +(define (request-body-port/knots r) + (cond + ((member '(chunked) (request-transfer-encoding r)) + (make-chunked-input-port (request-port r) + #:keep-alive? #t)) + (else + (let ((content-length + (request-content-length r))) + (make-delimited-input-port + (request-port r) + content-length + (lambda (bytes-read) + (raise-exception + (make-request-body-ended-prematurely-error bytes-read)))))))) + +(define (read-request-body/knots r) + (cond + ((member '(chunked) (request-transfer-encoding r)) + (get-bytevector-all + (request-body-port/knots r))) + (else + (let ((content-length + (request-content-length r))) + (if content-length + (get-bytevector-n + (request-body-port/knots r) + content-length) + #f))))) + (define (extend-response r k v . additional) (define (extend-alist alist k v) (let ((pair (assq k alist))) diff --git a/tests/web-server.scm b/tests/web-server.scm index 205d6a2..c21851e 100644 --- a/tests/web-server.scm +++ b/tests/web-server.scm @@ -150,6 +150,74 @@ (utf8->string (get-bytevector-n body 3))))))) +(run-fibers-for-tests + (lambda () + (let* ((web-server + (run-knots-web-server + (lambda (request) + (if (string=? (utf8->string + (read-request-body/knots request)) + "☺") + (values (build-response #:code 200) + "") + (values (build-response #:code 500) + ""))) + #:port 0)) ;; Bind to any port + (port + (web-server-port web-server)) + (uri + (build-uri 'http #:host "127.0.0.1" #:port port))) + + (let ((response + body + (http-post + uri + #:body "☺" + #:port (non-blocking-open-socket-for-uri uri)))) + (assert-equal + 200 + (response-code response)))))) + +(run-fibers-for-tests + (lambda () + (let* ((channel (make-channel)) + (web-server + (run-knots-web-server + (lambda (request) + (with-exception-handler + (lambda (exn) + (put-message channel exn)) + (lambda () + (read-request-body/knots request)) + #:unwind? #t)) + #:port 0)) ;; Bind to any port + (port + (web-server-port web-server)) + (uri + (build-uri 'http #:host "127.0.0.1" #:port port))) + + (let* ((port (non-blocking-open-socket-for-uri uri)) + (request + (build-request + uri + #:method 'POST + #:version '(1 . 1) + #:headers `((connection close) + (content-length . 20) + (Content-Type . "application/octet-stream")) + #:port port))) + + (set-port-encoding! port "ISO-8859-1") + (let ((request (write-request request port))) + (display "12") + (force-output port) + + (close-port port))) + + (assert-true + (request-body-ended-prematurely-error? + (get-message channel)))))) + ;; Test hanlding of exceptions when writing the response to a client (run-fibers-for-tests (lambda ()