Better use of srfi-35 conditions.

This commit defines `&not-found` and `&forbidden` condition types and allows
special handlers to be registered to handle them during requests.

All default handlers now ignore the value assigned to the `%default-headers`
parameter and always use "text/plain; charset=utf-8" as content type.

`cantius.scm` now imports SRFI-35 is using prefix, copyright years have been
updated.

1 files changed, 81 insertions, 40 deletions

diff --git a/src/guile/cantius.scm b/src/guile/cantius.scm
index af37a32..601427e 100644
--- a/src/guile/cantius.scm
+++ b/src/guile/cantius.scm
@@ -1,11 +1,11 @@
-;; SPDX-License-Identifier: CC0-1.0
-;;
-;; Copyright (C) 2023 Wojtek Kosior <koszko@koszko.org>
+;;; SPDX-License-Identifier: CC0-1.0
+;;;
+;;; Copyright (C) 2023, 2024 Wojtek Kosior <koszko@koszko.org>
 
 (define-module (cantius)
   #: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-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:)
@@ -31,17 +31,33 @@
 (define legal-path?
   (negate (cut regexp-exec %illegal-path-regex <>)))
 
+(export &not-found)
+(export not-found-condition?)
+(s35:define-condition-type &not-found s35:&condition
+  not-found-condition?)
+
+(export &forbidden)
+(export forbidden-condition?)
+(s35:define-condition-type &forbidden s35:&condition
+  forbidden-condition?)
+
 (export find-resource-file)
 (define* (find-resource-file file #:optional (root-path (%resource-root-path)))
   (unless (legal-path? file)
-    (raise (condition
-            (&error)
-            (&message (message (format #f "Illegal path ~a" file))))))
+    (raise (s35:condition
+            (&forbidden)
+            (s35:&message
+             (message (format #f "Illegal resource path ~a" file))))))
 
   (let loop ((paths root-path))
     (match paths
       (()
-       #f)
+       (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" <> file) file-path)
         . paths-rest)
        (or (and (stat file-path #f) file-path)
@@ -64,18 +80,31 @@
 (define-public %redirect/remove-query?
   (make-parameter #t))
 
+(define *%default-headers
+  '((content-type . (text/plain (charset . "utf-8")))))
+
+(define-public %default-headers
+  (make-parameter *%default-headers))
+
 (define-public %default-handler
   (make-parameter (lambda (request body . _)
-                    (values (build-response* #:code 404)
+                    (values (build-response* #:headers *%default-headers
+                                             #:code 404)
                             "There's no page with this address :("))))
 
-(define-public %default-headers
-  (make-parameter '((content-type . (text/plain (charset . "utf-8"))))))
+(define-public %not-found-handler
+  (make-parameter (%default-handler)))
+
+(define-public %forbidden-handler
+  (make-parameter (lambda (request body . _)
+                    (values (build-response* #:headers *%default-headers
+                                             #:code 403)
+                            "You. Shall not. Pass. (forbidden)"))))
 
 
 
 (define-immutable-record-type* endpoint
-  (handler #:default (lambda _ (raise (condition (&error)))))
+  (handler #:default (lambda _ (raise (s35:condition (s35:&error)))))
   (path #:default '())
   (parameters #:default '())
   #:export? yes,of-course)
@@ -99,23 +128,26 @@
     (match-let ((($* endpoint-tree-node direct-match any-match children)
                  tree-node))
       (when (endset? direct-match)
-        (raise (condition
-                (&error)
-                (&message (message (format #f "Endset already registered for ~s"
-                                           (processed-segments)))))))
+        (raise (s35:condition
+                (s35:&error)
+                (s35:&message
+                 (message (format #f "Endset already registered for ~s"
+                                  (processed-segments)))))))
 
       (match segments
         (()
          (cond (direct-match
-                (raise (condition
-                        (&error)
-                        (&message (message (format #f "Endpoint already registered for ~s"
-                                                   path))))))
+                (raise (s35:condition
+                        (s35:&error)
+                        (s35:&message
+                         (message (format #f "Endpoint already registered for ~s"
+                                          path))))))
                ((and (endset? what) (not (s146:mapping-empty? children)))
-                (raise (condition
-                        (&error)
-                        (&message (message (format #f "Endpoints already registered under ~s"
-                                                   path))))))
+                (raise (s35:condition
+                        (s35:&error)
+                        (s35:&message
+                         (message (format #f "Endpoints already registered under ~s"
+                                          path))))))
                (#t
                 (endpoint-tree-node
                  #:<- tree-node
@@ -123,15 +155,17 @@
 
         ('any
          (cond (any-match
-                (raise (condition
-                        (&error)
-                        (&message (message (format #f "\"any\" endpoint already registered for ~s"
-                                                   path))))))
+                (raise (s35:condition
+                        (s35:&error)
+                        (s35:&message
+                         (message (format #f "\"any\" endpoint already registered for ~s"
+                                          path))))))
                ((endset? what)
-                (raise (condition
-                        (&error)
-                        (&message (message (format #f "endset should be registered at normal path, not ~s"
-                                                   path))))))
+                (raise (s35:condition
+                        (s35:&error)
+                        (s35:&message
+                         (message (format #f "endset should be registered at normal path, not ~s"
+                                          path))))))
                (#t
                 (endpoint-tree-node
                  #:<- tree-node
@@ -171,9 +205,10 @@
                     (extra-handler-args-syntax #'())))
         ((segment-arg . rest)
          (identifier? #'segment-arg)
-         (raise (condition
-                 (&error)
-                 (&message (message "Binding identifiers to path segments not yet supported")))))
+         (raise (s35:condition
+                 (s35:&error)
+                 (s35:&message
+                  (message "Binding identifiers to path segments not yet supported")))))
         (((unquote segment-expression) . rest)
          (loop (cons #',segment-expression path-segments) #'rest))
         (((unquote-splicing segments-expression) . rest)
@@ -347,7 +382,8 @@
                    (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
+          (values (build-response* #:headers *%default-headers
+                                   #:redirect-to (uri:build-relative-ref
                                                   #:path (redirect-path)
                                                   #:query (redirect-query)))
                   "Redirect...")
@@ -359,14 +395,19 @@
 
                   (display msg (current-error-port))
 
-                  (escape (build-response* #:code 500)
+                  (escape (build-response* #:headers *%default-headers
+                                           #: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) '())))))))))
+                    (guard (ex ((s35:condition-has-type? ex &not-found)
+                                ((%not-found-handler) request body))
+                               ((s35:condition-has-type? ex &forbidden)
+                                ((%forbidden-handler) request body)))
+                      (apply (endpoint-handler endpoint) request body
+                             (or (and=> path-tail list) '()))))))))))
 
     (with-parameters* (map car parameters) (map cdr parameters)
       (lambda ()
@@ -376,7 +417,7 @@
           ((response response-body)
            (values response response-body))
           (something-else
-           (values (build-response* #:code 500)
+           (values (build-response* #:headers *%default-headers #:code 500)
                    (format #f "Invalid return values from handler:~%~a"
                            something-else))))))))