diff options
| -rw-r--r-- | src/guile/cantius.scm | 121 |
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 ¬-found) +(export not-found-condition?) +(s35:define-condition-type ¬-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 + (¬-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 ¬-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)))))))) |