diff --git a/knots.scm b/knots.scm index dee18a5..05b2a1a 100644 --- a/knots.scm +++ b/knots.scm @@ -2,7 +2,6 @@ #:use-module (srfi srfi-1) #:use-module (ice-9 match) #:use-module (ice-9 suspendable-ports) - #:use-module (fibers) #:use-module (fibers conditions) #:use-module (system repl debug) #:export (call-with-default-io-waiters @@ -16,9 +15,7 @@ knots-exception? knots-exception-stack - print-backtrace-and-exception/knots - - spawn-fiber/knots)) + print-backtrace-and-exception/knots)) (define (call-with-default-io-waiters thunk) (parameterize @@ -70,58 +67,6 @@ (define* (print-backtrace-and-exception/knots exn #:key (port (current-error-port))) - (define (get-string port stack) - (define stack-len - (stack-length stack)) - - (let ((knots-stacks - (map knots-exception-stack - (filter knots-exception? - (simple-exceptions exn))))) - - (let* ((stack-vec - (stack->vector stack)) - (stack-vec-length - (vector-length stack-vec))) - (print-frames (list->vector - (drop - (vector->list stack-vec) - (if (< stack-vec-length 5) - 0 - 4))) - port - #:count (stack-length stack))) - (for-each - (lambda (stack) - (let* ((stack-vec - (stack->vector stack)) - (stack-vec-length - (vector-length stack-vec))) - (print-frames (list->vector - (drop - (vector->list stack-vec) - (if (< stack-vec-length 4) - 0 - 3))) - port - #:count (stack-length stack)))) - knots-stacks) - (print-exception - port - (if (null? knots-stacks) - (stack-ref stack - (if (< stack-len 4) - stack-len - 4)) - (let* ((stack (last knots-stacks)) - (stack-len (stack-length stack))) - (stack-ref stack - (if (< stack-len 3) - stack-len - 3)))) - '%exception - (list exn)))) - (let* ((stack (match (fluid-ref %stacks) ((stack-tag . prompt-tag) @@ -130,53 +75,56 @@ 0 (and prompt-tag 1))) (_ (make-stack #t)))) - (string-port - (open-output-string)) + (stack-len + (stack-length stack)) (error-string - (with-exception-handler - (lambda (exn) - (display (get-output-string string-port) - port) - (close-output-port string-port) - (display "\n\n" port) + (call-with-output-string + (lambda (port) + (let ((knots-stacks + (map knots-exception-stack + (filter knots-exception? + (simple-exceptions exn))))) - (backtrace port) - (simple-format + (let* ((stack-vec + (stack->vector stack)) + (stack-vec-length + (vector-length stack-vec))) + (print-frames (list->vector + (drop + (vector->list stack-vec) + (if (< stack-vec-length 5) + 0 + 4))) + port + #:count (stack-length stack))) + (for-each + (lambda (stack) + (let* ((stack-vec + (stack->vector stack)) + (stack-vec-length + (vector-length stack-vec))) + (print-frames (list->vector + (drop + (vector->list stack-vec) + (if (< stack-vec-length 4) + 0 + 3))) + port + #:count (stack-length stack)))) + knots-stacks) + (print-exception port - "\nexception in print-backtrace-and-exception/knots: ~A\n" - exn) - (raise-exception exn)) - (lambda () - (get-string string-port stack) - (let ((str (get-output-string string-port))) - (close-output-port string-port) - str))))) + (if (null? knots-stacks) + (stack-ref stack + (if (< stack-len 4) + stack-len + 4)) + (let* ((stack (last knots-stacks)) + (stack-len (stack-length stack))) + (stack-ref stack + (if (< stack-len 3) + stack-len + 3)))) + '%exception + (list exn))))))) (display error-string port))) - -(define* (spawn-fiber/knots thunk #:optional scheduler #:key parallel?) - (spawn-fiber - (lambda () - (with-exception-handler - (lambda (exn) - (display "Uncaught exception in task:\n" - (current-error-port)) - (print-backtrace-and-exception/knots exn)) - (lambda () - (with-exception-handler - (lambda (exn) - (let ((stack - (match (fluid-ref %stacks) - ((stack-tag . prompt-tag) - (make-stack #t - 0 prompt-tag - 0 (and prompt-tag 1))) - (_ - (make-stack #t))))) - (raise-exception - (make-exception - exn - (make-knots-exception stack))))) - thunk)) - #:unwind? #t)) - scheduler - #:parallel? parallel?)) diff --git a/knots/web-server.scm b/knots/web-server.scm index d0b13ce..4d7240b 100644 --- a/knots/web-server.scm +++ b/knots/web-server.scm @@ -228,6 +228,8 @@ on the procedure being called at any particular time." (adapt-response-version response (request-version request)) body)) + ((not body) + (values response #vu8())) ((string? body) (let* ((type (response-content-type response '(text/plain))) @@ -241,15 +243,16 @@ on the procedure being called at any particular time." `(,@type (charset . ,charset)))) (string->bytevector body charset)))) ((not (or (bytevector? body) - (procedure? body) - (eq? #f body))) + (procedure? body))) (raise-exception (make-exception-with-irritants (list (make-exception-with-message "unexpected body type") body)))) ((and (response-must-not-include-body? response) - body) + body + ;; FIXME make this stricter: even an empty body should be prohibited. + (not (zero? (bytevector-length body)))) (raise-exception (make-exception-with-irritants (list (make-exception-with-message @@ -259,24 +262,25 @@ on the procedure being called at any particular time." ;; check length; assert type; add other required fields? (values (response-maybe-add-connection-header-value request - (cond - ((procedure? body) - (if (response-content-length response) - response - (extend-response response - 'transfer-encoding - '((chunked))))) - ((bytevector? body) - (let ((rlen (response-content-length response)) - (blen (bytevector-length body))) - (cond - (rlen (if (= rlen blen) - response - (error "bad content-length" rlen blen))) - (else (extend-response response 'content-length blen))))) - (else response))) + (if (procedure? body) + (if (response-content-length response) + response + (extend-response response + 'transfer-encoding + '((chunked)))) + (let ((rlen (response-content-length response)) + (blen (bytevector-length body))) + (cond + (rlen (if (= rlen blen) + response + (error "bad content-length" rlen blen))) + (else (extend-response response 'content-length blen)))))) (if (eq? (request-method request) 'HEAD) - #f + (raise-exception + (make-exception-with-irritants + (list (make-exception-with-message + "unexpected body type") + body))) body))))) (define (with-stack-and-prompt thunk) @@ -401,48 +405,41 @@ on the procedure being called at any particular time." (let ((response-start-time (get-internal-real-time)) (body-written? - (cond - ((and (procedure? body) - (not - (eq? (request-method request) - 'HEAD))) - (let* ((type (response-content-type response - '(text/plain))) - (declared-charset (assq-ref (cdr type) 'charset)) - (charset (or declared-charset "ISO-8859-1")) - (body-port - (if (response-content-length response) - client - (make-chunked-output-port/knots - client - #:keep-alive? #t - #:buffering - (- buffer-size - (chunked-output-port-overhead-bytes - buffer-size)))))) - (set-port-encoding! body-port charset) - (let ((body-written? - (with-exception-handler - (lambda (exn) - #f) - (lambda () - (with-exception-handler - (lambda (exn) - (print-backtrace-and-exception/knots exn) - (raise-exception exn)) - (lambda () - (body body-port))) - #t) - #:unwind? #t))) - (unless (response-content-length response) - (close-port body-port)) - body-written?))) - ((bytevector? body) - (put-bytevector client body) - #t) - (else - ;; No body to write - #t)))) + (if (procedure? body) + (let* ((type (response-content-type response + '(text/plain))) + (declared-charset (assq-ref (cdr type) 'charset)) + (charset (or declared-charset "ISO-8859-1")) + (body-port + (if (response-content-length response) + client + (make-chunked-output-port/knots + client + #:keep-alive? #t + #:buffering + (- buffer-size + (chunked-output-port-overhead-bytes + buffer-size)))))) + (set-port-encoding! body-port charset) + (let ((body-written? + (with-exception-handler + (lambda (exn) + #f) + (lambda () + (with-exception-handler + (lambda (exn) + (print-backtrace-and-exception/knots exn) + (raise-exception exn)) + (lambda () + (body body-port))) + #t) + #:unwind? #t))) + (unless (response-content-length response) + (close-port body-port)) + body-written?)) + (begin + (put-bytevector client body) + #t)))) (if body-written? (begin (force-output client) diff --git a/tests/web-server.scm b/tests/web-server.scm index 67c6423..e456bf3 100644 --- a/tests/web-server.scm +++ b/tests/web-server.scm @@ -1,6 +1,5 @@ (use-modules (srfi srfi-71) (rnrs bytevectors) - (ice-9 match) (ice-9 binary-ports) (ice-9 textual-ports) (tests) @@ -234,68 +233,4 @@ (assert-equal (get-message exception-handled-sucecssfully-channel) #t)))) -(run-fibers-for-tests - (lambda () - (let* ((web-server - (run-knots-web-server - (lambda (request) - (match (split-and-decode-uri-path - (uri-path (request-uri request))) - (("head-no-body") - (values '((content-type . (text/plain))) - #f)) - (("head-empty-body") - (values '((content-type . (text/plain))) - "")) - (("head-no-body-with-content-length") - (values '((content-type . (text/plain)) - (content-length . 10)) - #f)) - (("head-with-body") - (values '((content-type . (text/plain))) - "foo")) - (("head-procedure-body") - (values '((content-type . (text/plain))) - (lambda _ - (error "should not be run")))) - (("head-procedure-body-with-content-length") - (values '((content-type . (text/plain)) - (content-length . 10)) - (lambda _ - (error "should not be run")))))) - #:port 0)) ;; Bind to any port - (port - (web-server-port web-server))) - - (define* (head path) - (let ((uri - (build-uri 'http #:host "127.0.0.1" #:port port - #:path path))) - (http-head - uri - #:port (non-blocking-open-socket-for-uri uri)))) - - (let ((response - (head "/head-no-body"))) - (assert-equal 200 (response-code response))) - (let ((response - (head "/head-empty-body"))) - (assert-equal 200 (response-code response)) - (assert-equal 0 (response-content-length response))) - (let ((response - (head "/head-no-body-with-content-length"))) - (assert-equal 200 (response-code response)) - (assert-equal 10 (response-content-length response))) - (let ((response - (head "/head-with-body"))) - (assert-equal 200 (response-code response)) - (assert-equal 3 (response-content-length response))) - (let ((response - (head "/head-procedure-body"))) - (assert-equal 200 (response-code response))) - (let ((response - (head "/head-procedure-body-with-content-length"))) - (assert-equal 200 (response-code response)) - (assert-equal 10 (response-content-length response)))))) - (display "web-server test finished successfully\n")