diff options
Diffstat (limited to 'src/guile')
| -rw-r--r-- | src/guile/cantius.scm | 253 |
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)) |