diff options
| -rw-r--r-- | src/guile/cantius.scm | 85 | ||||
| -rw-r--r-- | tests/guile/cantius-test.scm | 5 |
2 files changed, 50 insertions, 40 deletions
diff --git a/src/guile/cantius.scm b/src/guile/cantius.scm index 1f6ec34..fe8131a 100644 --- a/src/guile/cantius.scm +++ b/src/guile/cantius.scm @@ -317,45 +317,56 @@ (path (uri:split-and-decode-uri-path path-string)) (($* endpoint-ref-result path-tail endpoint parameters) (query-endset root-endset path (%catchall-ref-result)))) + (define (normalized-path-string) + (format #f "/~a" (uri:encode-and-join-uri-path path))) + + (define (redirect-path) + (if (%redirect/normalize-path?) + (normalized-path-string) + (uri:uri-path (request-uri request)))) + + (define (redirect-query) + (if (%redirect/remove-query?) + #f + (uri:uri-query uri))) + + (define (compute-response) + (if (or (and (%redirect/normalize-path?) + (regexp-exec %ugly-uri-path-regex path-string)) + (and (%redirect/remove-query?) + (uri:uri-query uri))) + (values (build-response* #:redirect-to (uri:build-relative-ref + #:path (redirect-path) + #:query (redirect-query))) + "Redirect...") + (let/ec escape + (with-exception-handler + (lambda (ex) + (define msg + (exception->msg ex)) + + (display msg (current-error-port)) + + (escape (build-response* #:code 500) + (string-append msg "\nBacktrace:\n\n" (bt-string)))) + (lambda () + (parameterize ((%current-path path) + (%current-path-string path-string)) + (start-stack 'cantius-request + (apply (endpoint-handler endpoint) request body + (or (and=> path-tail list) '()))))))))) + (with-parameters* (map car parameters) (map cdr parameters) (lambda () - (define (normalized-path-string) - (format #f "/~a" (uri:encode-and-join-uri-path path))) - - (define (redirect-path) - (if (%redirect/normalize-path?) - (normalized-path-string) - (uri:uri-path (request-uri request)))) - - (define (redirect-query) - (if (%redirect/remove-query?) - #f - (uri:uri-query uri))) - - (if (or (and (%redirect/normalize-path?) - (regexp-exec %ugly-uri-path-regex path-string)) - (and (%redirect/remove-query?) - (uri:uri-query uri))) - (values (build-response* #:redirect-to (uri:build-relative-ref - #:path (redirect-path) - #:query (redirect-query))) - "Redirect...") - (let/ec escape - (with-exception-handler - (lambda (ex) - (define msg - (exception->msg ex)) - - (display msg (current-error-port)) - - (escape (build-response* #:code 500) - (string-append msg "\nBacktrace:\n\n" (bt-string)))) - (lambda () - (parameterize ((%current-path path) - (%current-path-string path-string)) - (start-stack 'cantius-request - (apply (endpoint-handler endpoint) request body - (or (and=> path-tail list) '())))))))))))) + (match ((compose list compute-response)) + ((response-body) + (values (build-response*) response-body)) + ((response response-body) + (values response response-body)) + (something-else + (values (build-response* #:code 500) + (format #f "Invalid return values from handler:~%~a" + something-else)))))))) (define-public (run-cantius endset . server-args) (apply run-server (cut handler <> <> endset) server-args)) diff --git a/tests/guile/cantius-test.scm b/tests/guile/cantius-test.scm index deceab5..f3e628a 100644 --- a/tests/guile/cantius-test.scm +++ b/tests/guile/cantius-test.scm @@ -49,9 +49,8 @@ (define-endpoint %my-endset about-ms ("cool-companies" "ms" "about") '() - (values (build-response*) - "Microsoft is my favorite company. I started using - Microsoft at the age of...")) + "Microsoft is my favorite company. I started using + Microsoft at the age of...") (define-endpoint %my-endset broken ("cool-companies" "ms" "product-list") '() |