(BREAKING!) Use srfi-247 syntactic monads instead of parameters.

This is a rework of most of Cantius, including its API.

3 files changed, 440 insertions, 384 deletions

diff --git a/.dir-locals.el b/.dir-locals.el
index 634cdd5..266d78c 100644
--- a/.dir-locals.el
+++ b/.dir-locals.el
@@ -5,5 +5,4 @@
 ((scheme-mode
   .
   ;; Add guile indentation hints
-  ((eval . (put 'start-stack 'scheme-indent-function 1))
-   (eval . (put 'with-parameters* 'scheme-indent-function 2)))))
+  ((eval . (put 'start-stack 'scheme-indent-function 1)))))
diff --git a/src/guile/cantius.scm b/src/guile/cantius.scm
index 517c75f..cdf6379 100644
--- a/src/guile/cantius.scm
+++ b/src/guile/cantius.scm
@@ -3,32 +3,44 @@
 ;;; Copyright (C) 2023-2025 Wojtek Kosior <koszko@koszko.org>
 
 (define-module (cantius)
-  #:use-module ((rnrs bytevectors) #:prefix bv:)
-  #:use-module ((srfi srfi-1) #:select (filter-map fold))
+  #:use-module (scheme base)
+
+  #:use-module ((srfi srfi-1) #:select (drop fold last))
+  #:use-module ((srfi srfi-11) #:select (let*-values))
   #:use-module ((srfi srfi-26) #:select (cut))
-  #:use-module ((srfi srfi-34) #:select (guard raise))
   #:use-module ((srfi srfi-35) #:prefix s35:)
-  #:use-module ((srfi srfi-39) #:select (with-parameters*))
   #:use-module ((srfi srfi-128) #:select (make-default-comparator))
   #:use-module ((srfi srfi-146) #:prefix s146:)
+  #:use-module ((srfi srfi-247) #:select (define-syntactic-monad))
+
   #:use-module ((ice-9 format) #:select (format))
-  #:use-module ((ice-9 control) #:select (let/ec))
   #:use-module ((ice-9 exceptions) #:select
                 (exception-with-message? exception-message))
   #:use-module ((ice-9 regex) #:select
                 (match:substring match:end regexp-substitute/global))
+
   #:use-module ((system repl debug) #:select (terminal-width))
   #:use-module ((web http) #:select (read-headers))
-  #:use-module ((web request) #:select (request-headers request-uri))
-  #:use-module ((web response) #:select (build-response))
+  #:use-module ((web request) #:prefix req:)
+  #:use-module ((web response) #:prefix res:)
   #:use-module ((web uri) #:prefix uri:)
+
   #:use-module ((fibers web server) #:select (run-server))
   #:use-module ((de-paul-records) #:select
-                (define-immutable-record-type* match match-let match-let*
-                 match-lambda)))
+                (deftype match match-let match-let*))
+
+  #:duplicates (last))
+
+;;;
+;;; Source of Cantius, a HTTP server library for Guile, based on Fibers.
+;;;
 
 
 
+;;;
+;;; Condition types.
+;;;
+
 (export &not-found)
 (export not-found-condition?)
 (s35:define-condition-type &not-found s35:&condition
@@ -51,79 +63,25 @@
   condition-with-http-code?
   (http-code condition-http-code))
 
-(define-public (normalize-path path)
-  (define absolute?
-    (eqv? #\/ (string-ref path 0)))
-
-  (let loop ((parent-walks 0)
-             (processed '())
-             (to-process (string-split path #\/)))
-    (match (list parent-walks processed to-process)
-      ((0 () ())
-       (if absolute? "/" "."))
-      ((_ _ ())
-       (string-join (append (map (const "..") (iota parent-walks))
-                            (reverse processed))
-                    "/"
-                    (if absolute? 'prefix 'infix)))
-      ((_ _ ((? (cut member <> '("" ".")))
-             . rest))
-       (loop parent-walks processed rest))
-      ((_ () (".." . rest))
-       (loop (1+ parent-walks) '() rest))
-      ((_ (_ . processed-rest) (".." . rest))
-       (loop parent-walks processed-rest rest))
-      ((_ _ (segment . rest))
-       (loop parent-walks (cons segment processed) rest)))))
-
-(define %illegal-path-regex
-  ;; Assume normalized path, forbid parent directory ref.
-  (make-regexp "^/?[.][.](/.*)?$"))
-
-(export find-resource-file)
-(define* (find-resource-file file #:optional (root-path (%resource-root-path)))
-  (define normalized-file
-    (normalize-path file))
-
-  (when (regexp-exec %illegal-path-regex normalized-file)
-    (raise (s35:condition
-            (&forbidden)
-            (s35:&message
-             (message (format #f "Illegal resource path ~a" file))))))
-
-  (let loop ((paths root-path))
-    (match paths
-      (()
-       (raise (s35:condition
-               (&not-found)
-               (s35:&message
-                (message (format #f "Resource not found ~a" file))))))
-      ((? string?)
-       (loop (list root-path)))
-      (((= (cut format #f "~a/~a" <> normalized-file) file-path)
-        . paths-rest)
-       (or (and (stat file-path #f) file-path)
-           (loop paths-rest))))))
-
 
 
 ;;;
-;;; Multipart form parser
+;;; Multipart form parser.
 ;;;
 
-(define-immutable-record-type* form-data-part
+(deftype form-data-part
   #:export? #t
-  (name)
-  (headers)
-  (binary?)
-  (data))
+  name
+  headers
+  binary?
+  data)
 
 (define (hex-escape bytestring)
   (with-output-to-string
     (lambda ()
       (let loop ((idx 0))
-        (when (< idx (bv:bytevector-length bytestring))
-          (let ((byte (bv:bytevector-u8-ref bytestring idx)))
+        (when (< idx (bytevector-length bytestring))
+          (let ((byte (bytevector-u8-ref bytestring idx)))
             (cond ((or (> byte 127)
                        (= byte (char->integer #\\)))
                    (format #t "\\x~2,'0x" byte))
@@ -139,15 +97,15 @@
        (* 3 (string-count string #\\))))
 
   (define bytestring
-    (bv:make-bytevector byte-length))
+    (make-bytevector byte-length))
 
   (let loop ((byte-idx 0)
              (str-idx 0))
 
     (define (write-string str)
       (string-fold (lambda (char char-idx)
-                     (bv:bytevector-u8-set! bytestring char-idx
-                                            (char->integer char))
+                     (bytevector-u8-set! bytestring char-idx
+                                         (char->integer char))
                      (1+ char-idx))
                    byte-idx str))
 
@@ -163,7 +121,7 @@
               (str-idx* (+ 4 escape-idx))
               (escape-hex (substring string (+ 2 escape-idx) str-idx*))
               (byte (string->number escape-hex 16)))
-         (bv:bytevector-u8-set! bytestring byte-idx* byte)
+         (bytevector-u8-set! bytestring byte-idx* byte)
          (loop (1+ byte-idx*) str-idx*))))))
 
 (define %part-regex
@@ -246,11 +204,12 @@
             (data (let ((data-binary (hex-unescape data)))
                     (if binary?
                         data-binary
-                        (bv:utf8->string data-binary)))))))
+                        (utf8->string data-binary)))))))
        parts))
 
 (define-public (parse-request-multipart/form-data request body)
-  (match-let* ((content-type (assq-ref (request-headers request) 'content-type))
+  (match-let* ((content-type (assq-ref (req:request-headers request)
+                                       'content-type))
                (('multipart/form-data
                  . (= (cut assq-ref <> 'boundary)
                       (? identity boundary)))
@@ -274,9 +233,67 @@
 
 
 ;;;
-;;; Cookie parser
+;;; Several smaller helper utilities.
 ;;;
 
+;; Operations on URI paths.
+
+(define-public (normalize-path path)
+  (define absolute?
+    (eqv? #\/ (string-ref path 0)))
+
+  (let loop ((parent-walks 0)
+             (processed '())
+             (to-process (string-split path #\/)))
+    (match (list parent-walks processed to-process)
+      ((0 () ())
+       (if absolute? "/" "."))
+      ((_ _ ())
+       (string-join (append (map (const "..") (iota parent-walks))
+                            (reverse processed))
+                    "/"
+                    (if absolute? 'prefix 'infix)))
+      ((_ _ ((? (cut member <> '("" ".")))
+             . rest))
+       (loop parent-walks processed rest))
+      ((_ () (".." . rest))
+       (loop (1+ parent-walks) '() rest))
+      ((_ (_ . processed-rest) (".." . rest))
+       (loop parent-walks processed-rest rest))
+      ((_ _ (segment . rest))
+       (loop parent-walks (cons segment processed) rest)))))
+
+(define %illegal-path-regex
+  ;; Assume normalized path, forbid parent directory ref.
+  (make-regexp "^/?[.][.](/.*)?$"))
+
+(export find-resource-file)
+(define* (find-resource-file file root-paths)
+  (define normalized-file
+    (normalize-path file))
+
+  (when (regexp-exec %illegal-path-regex normalized-file)
+    (raise (s35:condition
+            (&forbidden)
+            (s35:&message
+             (message (format #f "Illegal resource path ~a" file))))))
+
+  (let loop ((paths root-paths))
+    (match paths
+      (()
+       (raise (s35:condition
+               (&not-found)
+               (s35:&message
+                (message (format #f "Resource not found ~a" file))))))
+      ((? string?)
+       (loop (list root-paths)))
+      (((= (cut format #f "~a/~a" <> normalized-file) file-path)
+        . paths-rest)
+       (or (and (stat file-path #f) file-path)
+           (loop paths-rest))))))
+
+;; Cookie parser.
+
 (define %cookie-regex
   (make-regexp (string-append
                 "^\\s*"
@@ -303,74 +320,111 @@
             (= match:end idx*))
        (loop idx* `((,name . ,value) . ,cookies-alist))))))
 
-
+;; Sugar over `build-response', with support for easy redirects.
 
-(define-public %current-path
-  (make-parameter #f))
+(export build-response*)
+(define* (build-response* headers #:key (redirect-to #f) (code #f) #:rest args)
+  (define code*
+    (or code (if redirect-to 301 200)))
 
-(define-public %current-path-string
-  (make-parameter #f))
+  (define redirect-to*
+    (if (string? redirect-to)
+        (uri:string->uri redirect-to)
+        redirect-to))
 
-(define-public %resource-root-path
-  (make-parameter '()))
+  (define headers*
+    (if redirect-to*
+        `((location . ,redirect-to*) . ,headers)
+        headers))
+
+  (let loop ((to-filter args)
+             (filtered '()))
+    (match to-filter
+      (()
+       (apply res:build-response #:code code* #:headers headers*
+              (reverse filtered)))
+      (((? (cut memq <> '(#:code #:redirect-to))) _ . rest)
+       (loop rest filtered))
+      ((keyword keyword-arg . rest)
+       (loop rest (cons* keyword-arg keyword filtered))))))
 
-(define-public %redirect/normalize-path?
-  (make-parameter #t))
+
 
-(define-public %redirect/remove-query?
-  (make-parameter #t))
+;;;
+;;; Cantius syntactic monad and default values to use as its arguments.
+;;;
 
-(define *%default-headers
+(export $)
+(define-syntactic-monad $
+  cant$resource-roots
+  cant$redirect/normalize-path?
+  cant$redirect/remove-query?
+  cant$default-headers
+  cant$http-code-handlers
+  cant$other-http-codes-handler
+  cant$request
+  cant$body
+  cant$current-path
+  cant$current-endpoint
+  cant$endpoint-matched-path)
+
+(define %default-headers
   '((content-type . (text/plain (charset . "utf-8")))))
 
-(define-public %default-headers
-  (make-parameter *%default-headers))
-
-(define (make-handler-parameter http-code default-message)
-  (make-parameter (lambda* (request body #:key message)
-                    (values (build-response* #:headers *%default-headers
-                                             #:code http-code)
-                            (or message default-message)))))
+(define (make-code-handler-pair http-code default-message)
+  (cons http-code
+        ($ lambda (. rest)
+          (values (build-response* %default-headers #:code http-code)
+                  (or (last rest) default-message)))))
 
-(define-public %not-found-handler
-  (make-handler-parameter 404 "There's no page with this address :("))
+(define %default-http-code-handlers
+  (map (cut apply make-code-handler-pair <>)
+       `((404 "There's no page with this address :(")
+         (403 "You. Shall not. Pass. (forbidden)")
+         (400 ,(format #f "Bad Request (you or your software seems to have ~
+                           messed sth up).")))))
 
-(define-public %forbidden-handler
-  (make-handler-parameter 403 "You. Shall not. Pass. (forbidden)"))
+($ define (default-other-http-codes-handler . rest)
+  (match-let (((message #:message http-code #:http-code . _) (reverse rest)))
+    (values (build-response* %default-headers #:code http-code)
+            (or message (format #f "HTTP code ~d" http-code)))))
 
-(define-public %bad-request-handler
-  (make-handler-parameter 400 (format #f "Bad Request (you or your software ~
-                                          seems to have messed sth up).")))
+($ define (get-code-handler code)
+   (or (and=> (assv code cant$http-code-handlers) cdr)
+       cant$other-http-codes-handler))
 
-(define-public %default-handler
-  (let ((not-found-handler (%not-found-handler)))
-    (make-parameter (lambda (request body . _)
-                      (not-found-handler request body)))))
+
 
-(define-public %other-codes-handler
-  (make-parameter (lambda* (request body http-code #:key message)
-                    (values (build-response* #:headers *%default-headers
-                                             #:code http-code)
-                            (or message
-                                (format #f "HTTP code ~d" http-code))))))
+;;;
+;;; Trees of endsets and endpoints.
+;;;
 
-
+(define (any->proc-list list-or-proc)
+  (if (procedure? list-or-proc)
+      (list list-or-proc)
+      list-or-proc))
 
-(define-immutable-record-type* endpoint
+(deftype endpoint
+  #:export? yes,of-course
   (handler #:default (lambda _ (raise (s35:condition (s35:&error)))))
   (path #:default '())
-  (parameters #:default '())
-  #:export? yes,of-course)
+  (arg-converters #:default '())
+  #:finalize (cut *endpoint
+                  #:<- <>
+                  (arg-converters #:=> any->proc-list)))
 
-(define-immutable-record-type* endpoint-tree-node
+(deftype endpoint-tree-node
   (direct-match #:default #f)
   (any-match #:default #f)
   (children #:default (s146:mapping (make-default-comparator))))
 
-(define-immutable-record-type* endset
+(deftype endset
+  #:export? sure,why-not
   (endpoints #:default (endpoint-tree-node))
-  (parameters #:default '())
-  #:export? sure,why-not)
+  (arg-converters #:default '())
+  #:finalize (cut *endset
+                  #:<- <>
+                  (arg-converters #:=> any->proc-list)))
 
 (define (endpoint-tree-+ tree path what)
   (let recurse ((segments path)
@@ -440,26 +494,81 @@
    #:<- endset-obj
    (endpoints (endpoint-tree-+ (endset-endpoints endset-obj) path what))))
 
+(define-syntactic-monad $query
+  qy$end qy$endpoint-matched-path qy$arg-converters)
+
+(define %default-endpoint
+  (endpoint (handler ($ lambda (. rest)
+                       ($ (cut apply ($ get-code-handler () 404) <...>)
+                          () (append rest '(#:http-code 404 #:message #f)))))
+            (arg-converters ($ lambda (. rest)
+                              ($ (cut apply values <...>)
+                                 ((cant$redirect/normalize-path? #f)
+                                  (cant$redirect/remove-query? #f)))))))
+
+(define (query-endset endset path-segments)
+  ($query let loop ((qy$end %default-endpoint)
+                    (qy$endpoint-matched-path path-segments)
+                    (qy$arg-converters (reverse (endset-arg-converters endset)))
+                    (current-segments path-segments)
+                    (current-place (endset-endpoints endset)))
+    ($query define (descend-subnode)
+      (match-let (((current-segment . segments-rest) current-segments)
+                  (($* endpoint-tree-node children) current-place))
+        (cond ((s146:mapping-ref/default children current-segment #f)
+               => (cut $query loop () segments-rest <>))
+              (else
+               ($query values)))))
+
+    (cond ((endset? current-place)
+           (let ((new-converters (reverse (endset-arg-converters endset))))
+             ($query loop ((qy$endpoint-matched-path current-segments)
+                           (qy$arg-converters (append new-converters
+                                                      qy$arg-converters)))
+                     current-segments (endset-endpoints current-place))))
+
+          ((null? current-segments)
+           (cond ((endpoint-tree-node-direct-match current-place)
+                  => (lambda (end)
+                       ($query values ((qy$end end)))))
+                 (else
+                  ($query values))))
+
+          ((endpoint-tree-node-any-match current-place)
+           ;; Remember that `end' can only be an endpoint here — we don't allow
+           ;; endsets with `any-match'.
+           => (lambda (end)
+                ($query descend-subnode ((qy$end end)))))
+
+          (else
+           ($query descend-subnode)))))
+
+
+
+;;;
+;;; Macro layer for endpoint definitions.
+;;;
+
 (eval-when (compile load eval)
-  (define-immutable-record-type* path-spec
-    (path-syntax)
-    (extra-handler-args-syntax))
+  (deftype path-spec
+    (path-stx)
+    (path-rest-stx))
 
   (define (syntax->path-spec x)
     (let loop ((path-segments '())
-               (path-syntax x))
-      (syntax-case path-syntax (unquote unquote-splicing)
+               (path-stx x))
+      (syntax-case path-stx (unquote unquote-splicing)
         (()
-         (path-spec (path-syntax #``(#,@(reverse path-segments)))
-                    (extra-handler-args-syntax #'())))
-        (rest-arg
-         (identifier? #'rest-arg)
-         (path-spec (path-syntax #``(#,@(reverse path-segments) . any))
-                    (extra-handler-args-syntax #'(rest-arg))))
+         (path-spec (path-stx #``(#,@(reverse path-segments)))
+                    (path-rest-stx #f)))
+        (rest-var
+         (identifier? #'rest-var)
+         (path-spec (path-stx #``(#,@(reverse path-segments)))
+                    (path-rest-stx #'rest-var)))
         ((unquote list-expression)
-         (path-spec (path-syntax #``(#,@(reverse path-segments)
+         (path-spec (path-stx #``(#,@(reverse path-segments)
                                      . ,list-expression))
-                    (extra-handler-args-syntax #'())))
+                    (path-rest-stx #f)))
         ((segment-arg . rest)
          (identifier? #'segment-arg)
          (raise (s35:condition
@@ -479,127 +588,47 @@
 (define-syntax define-endpoint
   (lambda (x)
     (syntax-case x ()
-      ((_ endset-identifier handler-identifier path parameters-list
-          handler-body handler-body-rest ...)
-       (and (identifier? #'webservice-identifier)
+      ((source-stx endset-identifier (handler-identifier . handler-formals)
+                   path arg-converters-list
+                   handler-body handler-body-rest ...)
+       (and (identifier? #'endset-identifier)
             (identifier? #'handler-identifier))
-       (match (syntax->path-spec #'path)
-         (($* path-spec path-syntax extra-handler-args-syntax)
-          #`(begin
-              (define (handler-identifier
-                       #,(datum->syntax #'handler-identifier 'request)
-                       #,(datum->syntax #'handler-identifier 'body)
-                       . #,extra-handler-args-syntax)
-                handler-body handler-body-rest ...)
-
-              (define endset-identifier
-                (endset-+ endset-identifier #,path-syntax
-                          (endpoint (parameters parameters-list)
-                                    (handler handler-identifier)))))))))))
-
-(define-immutable-record-type* endpoint-ref-result
-  (path-tail)
-  (endpoint)
-  (parameters)
-  #:finalize (match-lambda
-               ((and result ($* endpoint-ref-result (parameters #f) endpoint))
-                (let ((parameters (match endpoint
-                                    (($* endpoint parameters)
-                                     parameters)
-                                    (($* endset parameters)
-                                     parameters))))
-                  (endpoint-ref-result #:<- result parameters)))
-               (result
-                result)))
-
-(define (default-endpoint)
-  (endpoint (handler (%default-handler))
-            (parameters `((,%redirect/normalize-path? . #f)
-                          (,%redirect/remove-query? . #f)))))
-
-(define* (endpoint-tree-ref tree path #:key
-          (default-endpoint (default-endpoint)))
-  (let loop ((segments path)
-             (tree-node tree)
-             (best-any-match-endpoint default-endpoint)
-             (best-any-match-path #f))
-    (define (default-result)
-      (endpoint-ref-result (path-tail best-any-match-path)
-                           (endpoint best-any-match-endpoint)))
-
-    (match segments
-      (()
-       (match tree-node
-         (($* endpoint-tree-node (direct-match (? identity endpoint)))
-          (endpoint-ref-result (path-tail #f) endpoint))
-         (_
-          (default-result))))
-
-      ((current-segment . segments-rest)
-       (match-let* (((best-any-match-endpoint best-any-match-path)
-                     (or (and=> (endpoint-tree-node-any-match tree-node)
-                                (cut list <> segments))
-                         (list best-any-match-endpoint best-any-match-path)))
-                    (children (endpoint-tree-node-children tree-node))
-                    (subnode (s146:mapping-ref/default children current-segment
-                                                       #f)))
-         (cond (subnode
-                (loop segments-rest subnode
-                      best-any-match-endpoint best-any-match-path))
-               (best-any-match-endpoint
-                (endpoint-ref-result (path-tail best-any-match-path)
-                                     (endpoint best-any-match-endpoint)))
-               (#t
-                (default-result))))))))
-
-(define* (query-endset endset path #:optional (default #f))
-  (match-let loop ((($* endset endpoints (parameters endset-parameters)) endset)
-                   (path path)
-                   (parameters-lists '()))
-    (match (endpoint-tree-ref endpoints path)
-      (($* endpoint-ref-result
-           path-tail
-           (endpoint (? endset? next-endset)))
-       (loop next-endset path-tail (cons endset-parameters parameters-lists)))
-      (result
-       (endpoint-ref-result
-        #:<- result
-        (parameters #:-> (apply append (reverse (cons* parameters
-                                                       endset-parameters
-                                                       parameters-lists)))))))))
-
-
-
-(export build-response*)
-(define* (build-response* #:key (redirect-to #f) (headers (%default-headers))
-          (code #f) #:rest args)
-  (define code*
-    (or code (if redirect-to 301 200)))
-
-  (define redirect-to*
-    (if (string? redirect-to)
-        (uri:string->uri redirect-to)
-        redirect-to))
 
-  (define headers*
-    (if redirect-to*
-        `((location . ,redirect-to*) . ,headers)
-        headers))
+       (match-let* ((($* path-spec path-stx path-rest-stx)
+                     (syntax->path-spec #'path))
+
+                    (full-path-stx #``(,@#,path-stx . #,(or path-rest-stx '())))
+                    (stx (cut datum->syntax #'source-stx <>))
+                    (endpoint-matched-path (stx 'cant$endpoint-matched-path)))
+         #`(begin
+             (define evaluated-path
+               #,path-stx)
+
+             (define handler-identifier
+               (let ((path-len (length evaluated-path)))
+                 #,((macro-transformer (module-ref (resolve-module '(cantius))
+                                                   '$))
+                    #`(source-stx lambda (. handler-formals)
+                        (let (#,@(if path-rest-stx
+                                     #`((#,path-rest-stx
+                                         (drop #,endpoint-matched-path
+                                               path-len)))
+                                     '()))
+                          handler-body handler-body-rest ...)))))
+
+             (define endset-identifier
+               (endset-+ endset-identifier
+                         #,(if path-rest-stx
+                               #``(,@evaluated-path . any)
+                               #'evaluated-path)
+                         (endpoint (arg-converters arg-converters-list)
+                                   (handler handler-identifier))))))))))
 
-  (let loop ((to-filter args)
-             (filtered '()))
-    (match to-filter
-      (()
-       (apply build-response #:code code* #:headers headers*
-              (reverse filtered)))
-      (((? (cut memq <> '(#:code #:headers #:redirect-to))) _ . rest)
-       (loop rest filtered))
-      ((keyword keyword-arg . rest)
-       (loop rest (cons* keyword-arg keyword filtered))))))
+
 
-(define (%catchall-ref-result)
-  (endpoint-ref-result (path-tail #f)
-                       (endpoint (endpoint (handler (%default-handler))))))
+;;;
+;;; Dispatching of requests to handlers, with error handling.
+;;;
 
 (define %ugly-uri-path-regex
   (make-regexp ".+/(/|$)"))
@@ -611,104 +640,103 @@
               "Error occured.")
           ex))
 
-(define (handler request body root-endset)
-  (define (bt-string)
-    (call-with-output-string (lambda (port)
-                               (terminal-width 10000)
-                               (display-backtrace (make-stack #t 5 0) port))))
-
-  (match-let* ((uri (request-uri request))
-               (path-string (uri:uri-path uri))
-               (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-uri-path-string)
-      (format #f "/~a" (uri:encode-and-join-uri-path path)))
-
-    (define (redirect-path)
-      (if (%redirect/normalize-path?)
-          (normalized-uri-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?)
+(define (bt-string)
+  (call-with-output-string (lambda (port)
+                             (terminal-width 10000)
+                             (display-backtrace (make-stack #t 5 0) port))))
+
+($ define (meta-handler/no-redirect . rest)
+  (define (invoke-http-code-handler code ex)
+    (let ((msg (and (s35:condition-has-type? ex s35:&message)
+                    (s35:condition-message ex))))
+      ($ (cut apply ($ get-code-handler () code) <...>)
+         () (append rest `(#:http-code ,code #:message ,msg)))))
+
+  (guard (ex ((s35:condition-has-type? ex &not-found)
+              (invoke-http-code-handler 404 ex))
+             ((s35:condition-has-type? ex &forbidden)
+              (invoke-http-code-handler 403 ex))
+             ((s35:condition-has-type? ex &bad-request)
+              (invoke-http-code-handler 400 ex))
+             ((s35:condition-has-type? ex &condition-with-http-code)
+              (invoke-http-code-handler (condition-http-code ex) ex)))
+    (match ($ (cut (compose list apply) (endpoint-handler cant$current-endpoint)
+                   <...>)
+              () rest)
+      ((response-body)
+       (values (build-response* cant$default-headers) response-body))
+      ((response response-body)
+       (values response response-body))
+      (something-else
+            (values (build-response* %default-headers #:code 500)
+                    (format #f "Invalid return values from handler:~%~a"
+                            something-else))))))
+
+(define (web-server-handler request body root-endset)
+  (let* ((uri (req:request-uri request))
+         (path-string (uri:uri-path uri))
+         (path-segments (uri:split-and-decode-uri-path path-string)))
+    ($ define (meta-handler . rest)
+      (define (normalized-uri-path-string)
+        (format #f "/~a" (uri:encode-and-join-uri-path path-segments)))
+
+      (define (redirect-path)
+        (if cant$redirect/normalize-path?
+            (normalized-uri-path-string)
+            path-string))
+
+      (define (redirect-query)
+        (if cant$redirect/remove-query?
+            #f
+            (uri:uri-query uri)))
+
+      (if (or (and cant$redirect/normalize-path?
                    (regexp-exec %ugly-uri-path-regex path-string))
-              (and (%redirect/remove-query?)
+              (and cant$redirect/remove-query?
                    (uri:uri-query uri)))
-          (values (build-response* #:headers *%default-headers
+
+          (values (build-response* cant$default-headers
                                    #:code 307
                                    #:redirect-to (uri:build-relative-ref
                                                   #:path (redirect-path)
                                                   #:query (redirect-query)))
-                  "Redirect...")
-          (let/ec escape
-            (with-exception-handler
-                (if (getenv "CANTIUS_DEBUG")
-
-                    (lambda (ex)
-                      (define msg
-                        (exception->msg ex))
-
-                      (display msg (current-error-port))
-
-                      (escape (build-response* #:headers *%default-headers
-                                               #:code 500)
-                              (string-append msg "\nBacktrace:\n\n"
-                                             (bt-string))))
-
-                    (lambda (ex)
-                      (display (exception->msg ex) (current-error-port))
-
-                      (escape (build-response* #:headers *%default-headers
-                                               #:code 500)
-                              "Internal server error.")))
-
-              (lambda ()
-                (parameterize ((%current-path path)
-                               (%current-path-string path-string))
-                  (start-stack 'cantius-request
-                    (guard (ex ((s35:condition-has-type? ex &not-found)
-                                ((%not-found-handler) request body))
-
-                               ((s35:condition-has-type? ex &forbidden)
-                                ((%forbidden-handler) request body))
-
-                               ((s35:condition-has-type? ex &bad-request)
-                                ((%bad-request-handler) request body))
-
-                               ((s35:condition-has-type?
-                                 ex &condition-with-http-code)
-                                ((%other-codes-handler) request body
-                                 (condition-http-code ex)
-                                 #:message
-                                 (and (s35:condition-has-type? ex s35:&message)
-                                      (s35:condition-message ex)))))
-
-                      (apply (endpoint-handler endpoint) request body
-                             (or (and=> path-tail list) '()))))))))))
-
-    (let recurse ((parameters parameters))
-      (match parameters
-
-        (((param . value) . rest)
-         (parameterize ((param value))
-           (recurse rest)))
-
-        (()
-         (match ((compose list compute-response))
-           ((response-body)
-            (values (build-response*) response-body))
-           ((response response-body)
-            (values response response-body))
-           (something-else
-            (values (build-response* #:headers *%default-headers #:code 500)
-                    (format #f "Invalid return values from handler:~%~a"
-                            something-else)))))))))
+                  "307 Temporary Redirect...")
+
+          ($ (cut apply meta-handler/no-redirect <...>) () rest)))
+
+    (guard (ex ((and (getenv "CANTIUS_DEBUG")
+                     (bt-string))
+                => (lambda (backtrace)
+                     (let* ((desc (format #f "~a~%~
+                                              Backtrace:~%~%~a"
+                                          (exception->msg ex) backtrace)))
+                       (format (current-error-port) "In ~a request to `~a':~%~%"
+                               (symbol->string (req:request-method request))
+                               path-string)
+                       (display desc (current-error-port))
+                       (values (build-response* %default-headers #:code 500)
+                               desc))))
+               (else
+                (display (exception->msg ex) (current-error-port))
+                (values (build-response* %default-headers #:code 500)
+                        "Internal server error.")))
+
+      (start-stack 'cantius-request
+        ($query let*-values ((() (query-endset root-endset path-segments)))
+          ($ (apply compose meta-handler
+                    (append (reverse (endpoint-arg-converters qy$end))
+                            qy$arg-converters))
+             ((cant$resource-roots '())
+              (cant$redirect/normalize-path? #t)
+              (cant$redirect/remove-query? #t)
+              (cant$default-headers %default-headers)
+              (cant$http-code-handlers %default-http-code-handlers)
+              (cant$other-http-codes-handler default-other-http-codes-handler)
+              (cant$request request)
+              (cant$body body)
+              (cant$current-path path-segments)
+              (cant$current-endpoint qy$end)
+              (cant$endpoint-matched-path qy$endpoint-matched-path))))))))
 
 (define-public (run-cantius endset . server-args)
-  (apply run-server (cut handler <> <> endset) server-args))
+  (apply run-server (cut web-server-handler <> <> endset) server-args))
diff --git a/tests/guile/cantius-test.scm b/tests/guile/cantius-test.scm
index 091f8cc..3815449 100644
--- a/tests/guile/cantius-test.scm
+++ b/tests/guile/cantius-test.scm
@@ -186,9 +186,14 @@ Content-Length: ~d
                   #:use-module ((srfi srfi-18) #:select
                                 (make-thread thread-terminate! thread-yield!
                                  thread-start!))
+
                   #:use-module ((ice-9 format) #:select (format))
                   #:use-module ((ice-9 textual-ports) #:select (get-string-all))
-                  #:use-module (cantius))
+
+                  #:use-module ((web request) #:prefix req:)
+                  #:use-module ((web uri) #:prefix uri:)
+
+                  #:use-module ((cantius) #:prefix cant:))
 
                 (define sock-port
                   #f))
@@ -197,41 +202,51 @@ Content-Length: ~d
   (tu:test-assert
    (or (eval '(begin
                 (define %my-endset
-                  (endset))
+                  (cant:endset))
 
-                (define-endpoint %my-endset about-ms
+                (cant:define-endpoint %my-endset (about-ms)
                   ("cool-companies" "ms" "about") '()
                   "Microsoft is my favorite company.  I started using
  Microsoft at the age of...")
 
-                (define-endpoint %my-endset broken
+                (cant:define-endpoint %my-endset (broken)
                   ("cool-companies" "ms" "product-list") '()
                   (/ 1 0))
 
-                (define-endpoint %my-endset drm-wiki
+                (cant:define-endpoint %my-endset (drm-wiki)
                   ("drm-wiki" ,(string-append "dev" "ices") . some-path) '()
-                  (values (build-response*)
+
+                  (define path-string
+                    (uri:uri-path (req:request-uri cant$request)))
+
+                  (values (cant:build-response* cant$default-headers)
                           (format #f "~@{~@?~%~^~}"
-                                  "full page path1: ~a" (%current-path-string)
-                                  "full page path2: ~{/~a~}" (%current-path)
+                                  "full page path1: ~a" path-string
+                                  "full page path2: ~{/~a~}" cant$current-path
                                   "device page path: ~{/~a~}" some-path)))
 
-                (define-endpoint %my-endset about-google
+                (cant:define-endpoint %my-endset (about-google)
                   ,(list "cool-companies" "google" "about")
-                  `((,%redirect/normalize-path? . #f)
-                    (,%redirect/remove-query? . #f))
-                  (values (build-response*)
+                  (cant:$ lambda ()
+                    (cant:$ values ((cant$redirect/normalize-path? #f)
+                                    (cant$redirect/remove-query? #f))))
+
+                  (values (cant:build-response* cant$default-headers)
                           "Google provides the best services in the world..."))
 
-                (define-endpoint %my-endset static-files
+                (cant:define-endpoint %my-endset
+                    (static-files resource-root-path)
                   ("static" . file-path)
-                  `((,%resource-root-path
-                     . ,(dirname (search-path %load-path "cantius" ".scm")))
-                    (,%default-headers
-                     . ((content-type
-                         . (text/formatted (charset . "Windows-1252"))))))
+                  (cant:$ lambda ()
+                    (cant:$ values
+                            ((cant$default-headers
+                              '((content-type . (text/formatted
+                                                 (charset . "Windows-1252"))))))
+                            (dirname (search-path %load-path "cantius.scm"))))
+
                   (call-with-input-file
-                      (find-resource-file (string-join file-path "/"))
+                      (cant:find-resource-file (string-join file-path "/")
+                                               resource-root-path)
                     get-string-all))
 
                 (define server-sock
@@ -245,7 +260,7 @@ Content-Length: ~d
                 (define server-thread
                   (make-thread
                    (lambda ()
-                     (run-cantius %my-endset #:socket server-sock))))
+                     (cant:run-cantius %my-endset #:socket server-sock))))
 
                 (thread-start! server-thread)
 
@@ -294,19 +309,29 @@ Content-Length: ~d
    '("/cool-companies//ms/about" "/cool-companies/ms/about?a=b"))
 
   (tu:test-group "error-500"
-    (for-each
-     (lambda (debug-on?)
-       (when debug-on?
-         (setenv "CANTIUS_DEBUG" ""))
+    (define initial-debug-value
+      (getenv "CANTIUS_DEBUG"))
 
-       (define error-500-result
-         (get "/cool-companies/ms/product-list"))
+    (dynamic-wind
+      noop
 
-       (tu:test-eqv 500 (rsp:response-code (car error-500-result)))
+      (lambda ()
+        (for-each
+         (lambda (debug-on?)
+           (setenv "CANTIUS_DEBUG" (and debug-on? ""))
 
-       (tu:test-assert ((if debug-on? identity not)
-                        (string-contains (cadr error-500-result) "Backtrace"))))
-     '(#f #t)))
+           (define error-500-result
+             (get "/cool-companies/ms/product-list"))
+
+           (tu:test-eqv 500 (rsp:response-code (car error-500-result)))
+
+           (tu:test-assert ((if debug-on? identity not)
+                            (string-contains (cadr error-500-result)
+                                             "Backtrace"))))
+
+         '(#f #t)))
+
+      (cut setenv "CANTIUS_DEBUG" initial-debug-value)))
 
   (tu:test-group "error-404"
     (define error-404-result
@@ -318,10 +343,9 @@ Content-Length: ~d
     (define ipad-result
       (get "/drm-wiki/devices/apple/ipad"))
 
-    (tu:test-equal (format #f "~@{~a~%~}"
-                           "full page path1: /drm-wiki/devices/apple/ipad"
-                           "full page path2: /drm-wiki/devices/apple/ipad"
-                           "device page path: /apple/ipad")
+    (tu:test-equal (format #f "full page path1: /drm-wiki/devices/apple/ipad~%~
+                               full page path2: /drm-wiki/devices/apple/ipad~%~
+                               device page path: /apple/ipad~%")
                    (cadr ipad-result)))
 
   (tu:test-group "about-google"
@@ -350,7 +374,7 @@ Content-Length: ~d
     (tu:test-eqv 403 (rsp:response-code (car illegal-resource-result)))
 
     ;; Default handler for illegal resource accesses is expected to ignore the
-    ;; value of the `%default-headers` parameter.
+    ;; value of the `cant$default-headers` argument.
     (tu:test-equal '(text/plain (charset . "utf-8"))
                    (rsp:response-content-type (car illegal-resource-result))))
 
@@ -361,7 +385,7 @@ Content-Length: ~d
     (tu:test-eqv 404 (rsp:response-code (car missing-resource-result)))
 
     ;; Default handler for missing resource accesses is expected to ignore the
-    ;; value of the `%default-headers` parameter.
+    ;; value of the `cant$default-headers` argument.
     (tu:test-equal '(text/plain (charset . "utf-8"))
                    (rsp:response-content-type (car missing-resource-result))))
 
@@ -385,3 +409,8 @@ Content-Length: ~d
 
   (tu:test-equal "../j/k/l"
                  ((@ (cantius) normalize-path) "../j/k/l")))
+
+
+;;; Local Variables:
+;;; eval: (put 'cant:define-endpoint 'scheme-indent-function 2)
+;;; End: