From d8776e1ca00711b4153a827ed604eba55f7cd62b Mon Sep 17 00:00:00 2001
From: Wojtek Kosior <koszko@koszko.org>
Date: Tue, 19 Dec 2023 15:31:38 +0100
Subject: Allow handlers to only return response body.

---
 src/guile/cantius.scm | 85 +++++++++++++++++++++++++++++----------------------
 1 file changed, 48 insertions(+), 37 deletions(-)

(limited to 'src/guile/cantius.scm')

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))
-- 
cgit v1.2.3