diff options
author | Wojtek Kosior <koszko@koszko.org> | 2023-12-15 22:26:10 +0100 |
---|---|---|
committer | Wojtek Kosior <koszko@koszko.org> | 2023-12-16 13:16:48 +0100 |
commit | dac73785f73a91306a1c3eacbf04be720717ab76 (patch) | |
tree | 8636cfb50ec63d0e1e3d171cf3f723e1ff8769cd /src/guile | |
download | cantius-dac73785f73a91306a1c3eacbf04be720717ab76.tar.gz cantius-dac73785f73a91306a1c3eacbf04be720717ab76.zip |
Initial commit.
Diffstat (limited to 'src/guile')
-rw-r--r-- | src/guile/Makefile.am | 20 | ||||
-rw-r--r-- | src/guile/cantius.scm | 364 |
2 files changed, 384 insertions, 0 deletions
diff --git a/src/guile/Makefile.am b/src/guile/Makefile.am new file mode 100644 index 0000000..743ce74 --- /dev/null +++ b/src/guile/Makefile.am @@ -0,0 +1,20 @@ +# SPDX-License-Identifier: CC0-1.0 +# +# Copyright (C) 2023 Wojtek Kosior <koszko@koszko.org> + +GUILE_SOURCE_FILES = \ + $(PACKAGE).scm + +GUILE_OBJECT_FILES = \ + $(GUILE_SOURCE_FILES:.scm=.go) + +gobjdir = $(libdir)/guile/@GUILE_EFFECTIVE_VERSION@/site-ccache +nobase_gobj_DATA = $(GUILE_OBJECT_FILES) + +scmdir = $(datarootdir)/guile/site/@GUILE_EFFECTIVE_VERSION@ +nobase_dist_scm_DATA = $(GUILE_SOURCE_FILES) + +.scm.go: + $(top_builddir)/pre-inst-env $(GUILD) compile --output=$@ $< + +MOSTLYCLEANFILES = $(GUILE_OBJECT_FILES) diff --git a/src/guile/cantius.scm b/src/guile/cantius.scm new file mode 100644 index 0000000..146a8df --- /dev/null +++ b/src/guile/cantius.scm @@ -0,0 +1,364 @@ +;; SPDX-License-Identifier: CC0-1.0 +;; +;; Copyright (C) 2023 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-128) #:select (make-default-comparator)) + #:use-module ((srfi srfi-146) #:prefix s146:) + #: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 ((system repl debug) #:select (terminal-width)) + #:use-module ((web request) #:select (request-uri)) + #:use-module ((web uri) #:prefix uri:) + #: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-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)) + (match paths + (() + #f) + (((= (cut format #f "~a/~a" <> file) file-path) + . paths-rest) + (or (and (stat file-path #f) file-path) + (loop paths-rest)))))) + + + +(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) + #:export? yes,of-course) + +(define-immutable-record-type* endpoint-tree-node + (direct-match #:default #f) + (any-match #:default #f) + (children #:default (s146:mapping (make-default-comparator)))) + +(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) + #:export? sure,why-not) + +(define (endpoint-tree-+ tree path what) + (let recurse ((segments path) + (tree-node tree)) + (define (processed-segments) + (list-head path (- (length path) (length segments)))) + + (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))))))) + + (match segments + (() + (cond (direct-match + (raise (condition + (&error) + (&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)))))) + (#t + (endpoint-tree-node + #:<- tree-node + (direct-match what))))) + + ('any + (cond (any-match + (raise (condition + (&error) + (&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)))))) + (#t + (endpoint-tree-node + #:<- tree-node + (any-match what))))) + + (((? string? current-segment) . segments-rest) + (endpoint-tree-node + #:<- tree-node + (children (s146:mapping-update/default + children current-segment (cut recurse segments-rest <>) + %null-endpoint-tree-node)))))))) + +(define-public (endset-+ endset-obj path what) + (endset + #:<- endset-obj + (endpoints (endpoint-tree-+ (endset-endpoints endset-obj) path what)))) + +(eval-when (compile load eval) + (define-immutable-record-type* path-spec + (path-syntax) + (extra-handler-args-syntax)) + + (define (syntax->path-spec x) + (let loop ((path-segments '()) + (path-syntax x)) + (syntax-case path-syntax (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)))) + ((unquote list-expression) + (path-spec (path-syntax #``(#,@(reverse path-segments) + . ,list-expression)) + (extra-handler-args-syntax #'()))) + ((segment-arg . rest) + (identifier? #'segment-arg) + (raise (condition + (&error) + (&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) + (loop (cons #',@segments-expression path-segments) #'rest)) + ((segment . rest) + (string? (syntax->datum #'segment)) + (loop (cons #'segment path-segments) #'rest)))))) + +(export define-endpoint) +(define-syntax define-endpoint + (lambda (x) + (syntax-case x () + ((_ endset-identifier handler-identifier path + ((init-form ...) ...) + handler-body handler-body-rest ...) + (and (identifier? #'webservice-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 (init-form ...) ... + (handler handler-identifier))))))))))) + +(define-immutable-record-type* endpoint-ref-result + (path-tail) + (endpoint)) + +(define (endpoint-tree-ref tree path) + (let loop ((segments path) + (tree-node tree) + (best-any-match-endpoint #f) + (best-any-match-path #f)) + (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))) + (_ + #f))) + + ((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 + #f))))))) + +(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))))))) + + + +(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 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)) + + (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-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 + (endpoint-ref-result (path-tail #f) + (endpoint %catchall-endpoint))) + +(define %ugly-uri-path-regex + (make-regexp ".+/(/|$)")) + +(define (exception->msg ex) + (format #f "~a~%~a~%" + (if (exception-with-message? ex) + (format #f "Error: ~a." (exception-message ex)) + "Error occured.") + ex)) + +(define (handler request body root-endset) + (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) '())))))))))) + +(define-public (run-cantius endset . server-args) + (apply run-server (cut handler <> <> endset) server-args)) |