cbaines/guile-knots
1
Fork 0
Code Issues 1 Pull requests Activity Actions

Compare commits

base: cbaines:39ae5177f2527169721d7d895e2953021e136bf4
Branches Tags
cbaines:trunk
cbaines:pages
cbaines:actions-test
..
compare: cbaines:338d08081e5c90cc23978147394021fa84a4f5cc
Branches Tags
cbaines:trunk
cbaines:pages
cbaines:actions-test

No commits in common. "39ae5177f2527169721d7d895e2953021e136bf4" and "338d08081e5c90cc23978147394021fa84a4f5cc" have entirely different histories.
39ae5177f2 ... 338d08081e

3 changed files with 109 additions and 229 deletions
Download patch file Download diff file Expand all files Collapse all files

152
knots.scm
View file

@ -2,7 +2,6 @@
#:use-module (srfi srfi-1) #:use-module (srfi srfi-1)
#:use-module (ice-9 match) #:use-module (ice-9 match)
#:use-module (ice-9 suspendable-ports) #:use-module (ice-9 suspendable-ports)
#:use-module (fibers)
#:use-module (fibers conditions) #:use-module (fibers conditions)
#:use-module (system repl debug) #:use-module (system repl debug)
#:export (call-with-default-io-waiters #:export (call-with-default-io-waiters
@ -16,9 +15,7 @@
knots-exception? knots-exception?
knots-exception-stack knots-exception-stack
print-backtrace-and-exception/knots print-backtrace-and-exception/knots))
spawn-fiber/knots))
(define (call-with-default-io-waiters thunk) (define (call-with-default-io-waiters thunk)
(parameterize (parameterize
@ -70,58 +67,6 @@
(define* (print-backtrace-and-exception/knots (define* (print-backtrace-and-exception/knots
exn exn
#:key (port (current-error-port))) #: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 (let* ((stack
(match (fluid-ref %stacks) (match (fluid-ref %stacks)
((stack-tag . prompt-tag) ((stack-tag . prompt-tag)
@ -130,53 +75,56 @@
0 (and prompt-tag 1))) 0 (and prompt-tag 1)))
(_ (_
(make-stack #t)))) (make-stack #t))))
(string-port (stack-len
(open-output-string)) (stack-length stack))
(error-string (error-string
(with-exception-handler (call-with-output-string
(lambda (exn) (lambda (port)
(display (get-output-string string-port) (let ((knots-stacks
port) (map knots-exception-stack
(close-output-port string-port) (filter knots-exception?
(display "\n\n" port) (simple-exceptions exn)))))
(backtrace port) (let* ((stack-vec
(simple-format (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 port
"\nexception in print-backtrace-and-exception/knots: ~A\n" (if (null? knots-stacks)
exn) (stack-ref stack
(raise-exception exn)) (if (< stack-len 4)
(lambda () stack-len
(get-string string-port stack) 4))
(let ((str (get-output-string string-port))) (let* ((stack (last knots-stacks))
(close-output-port string-port) (stack-len (stack-length stack)))
str))))) (stack-ref stack
(if (< stack-len 3)
stack-len
3))))
'%exception
(list exn)))))))
(display error-string port))) (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?))

121
knots/web-server.scm
View file

@ -228,6 +228,8 @@ on the procedure being called at any particular time."
(adapt-response-version response (adapt-response-version response
(request-version request)) (request-version request))
body)) body))
((not body)
(values response #vu8()))
((string? body) ((string? body)
(let* ((type (response-content-type response (let* ((type (response-content-type response
'(text/plain))) '(text/plain)))
@ -241,15 +243,16 @@ on the procedure being called at any particular time."
`(,@type (charset . ,charset)))) `(,@type (charset . ,charset))))
(string->bytevector body charset)))) (string->bytevector body charset))))
((not (or (bytevector? body) ((not (or (bytevector? body)
(procedure? body) (procedure? body)))
(eq? #f body)))
(raise-exception (raise-exception
(make-exception-with-irritants (make-exception-with-irritants
(list (make-exception-with-message (list (make-exception-with-message
"unexpected body type") "unexpected body type")
body)))) body))))
((and (response-must-not-include-body? response) ((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 (raise-exception
(make-exception-with-irritants (make-exception-with-irritants
(list (make-exception-with-message (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? ;; check length; assert type; add other required fields?
(values (response-maybe-add-connection-header-value (values (response-maybe-add-connection-header-value
request request
(cond (if (procedure? body)
((procedure? body) (if (response-content-length response)
(if (response-content-length response) response
response (extend-response response
(extend-response response 'transfer-encoding
'transfer-encoding '((chunked))))
'((chunked))))) (let ((rlen (response-content-length response))
((bytevector? body) (blen (bytevector-length body)))
(let ((rlen (response-content-length response)) (cond
(blen (bytevector-length body))) (rlen (if (= rlen blen)
(cond response
(rlen (if (= rlen blen) (error "bad content-length" rlen blen)))
response (else (extend-response response 'content-length blen))))))
(error "bad content-length" rlen blen)))
(else (extend-response response 'content-length blen)))))
(else response)))
(if (eq? (request-method request) 'HEAD) (if (eq? (request-method request) 'HEAD)
#f (raise-exception
(make-exception-with-irritants
(list (make-exception-with-message
"unexpected body type")
body)))
body))))) body)))))
(define (with-stack-and-prompt thunk) (define (with-stack-and-prompt thunk)
@ -401,48 +405,41 @@ on the procedure being called at any particular time."
(let ((response-start-time (let ((response-start-time
(get-internal-real-time)) (get-internal-real-time))
(body-written? (body-written?
(cond (if (procedure? body)
((and (procedure? body) (let* ((type (response-content-type response
(not '(text/plain)))
(eq? (request-method request) (declared-charset (assq-ref (cdr type) 'charset))
'HEAD))) (charset (or declared-charset "ISO-8859-1"))
(let* ((type (response-content-type response (body-port
'(text/plain))) (if (response-content-length response)
(declared-charset (assq-ref (cdr type) 'charset)) client
(charset (or declared-charset "ISO-8859-1")) (make-chunked-output-port/knots
(body-port client
(if (response-content-length response) #:keep-alive? #t
client #:buffering
(make-chunked-output-port/knots (- buffer-size
client (chunked-output-port-overhead-bytes
#:keep-alive? #t buffer-size))))))
#:buffering (set-port-encoding! body-port charset)
(- buffer-size (let ((body-written?
(chunked-output-port-overhead-bytes (with-exception-handler
buffer-size)))))) (lambda (exn)
(set-port-encoding! body-port charset) #f)
(let ((body-written? (lambda ()
(with-exception-handler (with-exception-handler
(lambda (exn) (lambda (exn)
#f) (print-backtrace-and-exception/knots exn)
(lambda () (raise-exception exn))
(with-exception-handler (lambda ()
(lambda (exn) (body body-port)))
(print-backtrace-and-exception/knots exn) #t)
(raise-exception exn)) #:unwind? #t)))
(lambda () (unless (response-content-length response)
(body body-port))) (close-port body-port))
#t) body-written?))
#:unwind? #t))) (begin
(unless (response-content-length response) (put-bytevector client body)
(close-port body-port)) #t))))
body-written?)))
((bytevector? body)
(put-bytevector client body)
#t)
(else
;; No body to write
#t))))
(if body-written? (if body-written?
(begin (begin
(force-output client) (force-output client)

65
tests/web-server.scm
View file

@ -1,6 +1,5 @@
(use-modules (srfi srfi-71) (use-modules (srfi srfi-71)
(rnrs bytevectors) (rnrs bytevectors)
(ice-9 match)
(ice-9 binary-ports) (ice-9 binary-ports)
(ice-9 textual-ports) (ice-9 textual-ports)
(tests) (tests)
@ -234,68 +233,4 @@
(assert-equal (get-message exception-handled-sucecssfully-channel) (assert-equal (get-message exception-handled-sucecssfully-channel)
#t)))) #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") (display "web-server test finished successfully\n")