Facilitate using parameters for endpoint-specific behavior.

1 files changed, 125 insertions, 128 deletions

diff --git a/src/guile/cantius.scm b/src/guile/cantius.scm
index 146a8df..06e93b3 100644
--- a/src/guile/cantius.scm
+++ b/src/guile/cantius.scm
@@ -6,6 +6,7 @@
   #:use-module ((srfi srfi-26) #:select (cut))
   #:use-module ((srfi srfi-34) #:select (guard raise))
   #:use-module ((srfi srfi-35) #:select (condition &error &message))
+  #: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 ((ice-9 format) #:select (format))
@@ -18,19 +19,11 @@
   #:use-module ((web response) #:select (build-response))
   #:use-module ((fibers web server) #:select (run-server))
   #:use-module ((de-paul-records) #:select
-                (define-immutable-record-type* match match-let match-let*)))
+                (define-immutable-record-type* match match-let match-let*
+                 match-lambda)))
 
 
 
-(define-public current-path
-  (make-parameter #f))
-
-(define-public current-path-string
-  (make-parameter #f))
-
-(define-public %resource-root-path
-  (make-parameter '()))
-
 (export find-resource-file)
 (define* (find-resource-file file #:optional (root-path (%resource-root-path)))
   (let loop ((paths root-path))
@@ -44,10 +37,35 @@
 
 
 
+(define-public %current-path
+  (make-parameter #f))
+
+(define-public %current-path-string
+  (make-parameter #f))
+
+(define-public %resource-root-path
+  (make-parameter '()))
+
+(define-public %redirect/normalize-path?
+  (make-parameter #t))
+
+(define-public %redirect/remove-query?
+  (make-parameter #t))
+
+(define-public %default-handler
+  (make-parameter (lambda (request body . _)
+                    (values (build-response* #:code 404)
+                            "There's no page with this address :("))))
+
+(define-public %default-headers
+  (make-parameter '((content-type . (text/plain (charset . "utf-8"))))))
+
+
+
 (define-immutable-record-type* endpoint
   (handler #:default (lambda _ (raise (condition (&error)))))
-  (redirect/normalize-path? #:default 'true-by-default)
-  (redirect/remove-query? #:default 'true-by-default)
+  (path #:default '())
+  (parameters #:default '())
   #:export? yes,of-course)
 
 (define-immutable-record-type* endpoint-tree-node
@@ -57,11 +75,7 @@
 
 (define-immutable-record-type* endset
   (endpoints #:default (endpoint-tree-node))
-  ;;(resource-root-path #:default '())
-  ;;(fallback-handler #:default #f)
-  ;;(static-resource-headers #:default #f)
-  (redirect/normalize-path? #:default 'true-by-default)
-  (redirect/remove-query? #:default 'true-by-default)
+  (parameters #:default '())
   #:export? sure,why-not)
 
 (define (endpoint-tree-+ tree path what)
@@ -160,8 +174,7 @@
 (define-syntax define-endpoint
   (lambda (x)
     (syntax-case x ()
-      ((_ endset-identifier handler-identifier path
-          ((init-form ...) ...)
+      ((_ endset-identifier handler-identifier path parameters-list
           handler-body handler-body-rest ...)
        (and (identifier? #'webservice-identifier)
             (identifier? #'handler-identifier))
@@ -176,29 +189,46 @@
 
               (define endset-identifier
                 (endset-+ endset-identifier #,path-syntax
-                          (endpoint (init-form ...) ...
+                          (endpoint (parameters parameters-list)
                                     (handler handler-identifier)))))))))))
 
 (define-immutable-record-type* endpoint-ref-result
   (path-tail)
-  (endpoint))
-
-(define (endpoint-tree-ref tree path)
+  (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 #f)
+             (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 endpoint)))
-         ((? (const best-any-match-endpoint))
-          (endpoint-ref-result (path-tail best-any-match-path)
-                               (endpoint best-any-match-endpoint)))
+          (endpoint-ref-result (path-tail #f) endpoint))
          (_
-          #f)))
+          (default-result))))
 
       ((current-segment . segments-rest)
        (match-let* (((best-any-match-endpoint best-any-match-path)
@@ -215,54 +245,29 @@
                 (endpoint-ref-result (path-tail best-any-match-path)
                                      (endpoint best-any-match-endpoint)))
                (#t
-                #f)))))))
+                (default-result))))))))
 
 (define* (query-endset endset path #:optional (default #f))
-  (define (do-it? . args)
-    (match args
-      ((less-specific 'true-by-default)
-       less-specific)
-      ((less-specific more-specific)
-       more-specific)))
-
-  (let loop ((endset endset)
-             (path path)
-             (*redirect/normalize-path? 'true-by-default)
-             (*redirect/remove-query? 'true-by-default))
-    (match-let ((($* endset
-                     endpoints
-                     (redirect/normalize-path?
-                      (= (cut do-it? *redirect/normalize-path? <>)
-                         redirect/normalize-path?))
-                     (redirect/remove-query?
-                      (= (cut do-it? *redirect/remove-query? <>)
-                         redirect/remove-query?)))
-                 endset))
-      (define (update-endpoint base-endpoint)
-        (endpoint
-         #:<- base-endpoint
-         (redirect/normalize-path? #:=> (cut do-it? redirect/normalize-path?
-                                             <>))
-         (redirect/remove-query? #:=> (cut do-it? redirect/remove-query? <>))))
-
-      (match (endpoint-tree-ref endpoints path)
-        (#f
-         default)
-        (($* endpoint-ref-result path-tail (endpoint (? endset? endset)))
-         (loop endset path-tail redirect/normalize-path?
-               redirect/remove-query?))
-        (ref-result
-         (endpoint-ref-result #:<- ref-result
-                              (endpoint #:=> update-endpoint)))))))
+  (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)))))))))
 
 
 
-(define %default-headers
-  '((content-type . (text/plain (charset . "utf-8")))))
-
 (export build-response*)
-(define* (build-response* #:key (redirect-to #f) (headers %default-headers)
-                          (code #f) #:rest args)
+(define* (build-response* #:key (redirect-to #f) (headers (%default-headers))
+          (code #f) #:rest args)
   (define code*
     (or code (if redirect-to 301 200)))
 
@@ -287,16 +292,9 @@
       ((keyword keyword-arg . rest)
        (loop rest (cons* keyword-arg keyword filtered))))))
 
-(define %catchall-endpoint
-  (endpoint (handler (lambda (request body . _)
-                       (values (build-response* #:code 404)
-                               "There's no page with this address :(")))
-            (redirect/normalize-path? #f)
-            (redirect/remove-query? #f)))
-
-(define %catchall-ref-result
+(define (%catchall-ref-result)
   (endpoint-ref-result (path-tail #f)
-                       (endpoint %catchall-endpoint)))
+                       (endpoint (endpoint (handler (%default-handler))))))
 
 (define %ugly-uri-path-regex
   (make-regexp ".+/(/|$)"))
@@ -309,56 +307,55 @@
           ex))
 
 (define (handler request body root-endset)
+  (define (bt-string)
+    (call-with-output-string (lambda (port)
+                               (terminal-width 10000)
+                               (display-backtrace (make-stack #t 6 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)
-                (query-endset root-endset path %catchall-ref-result))
-               (($* endpoint redirect/normalize-path? redirect/remove-query?)
-                endpoint))
-    (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"
-                         (call-with-output-string
-                           (lambda (port)
-                             (terminal-width 80)
-                             (display-backtrace (make-stack #t 5 0) port))))))
-            (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) '()))))))))))
+               (($* endpoint-ref-result path-tail endpoint parameters)
+                (query-endset root-endset path (%catchall-ref-result))))
+    (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) '()))))))))))))
 
 (define-public (run-cantius endset . server-args)
   (apply run-server (cut handler <> <> endset) server-args))