aboutsummaryrefslogtreecommitdiff
path: root/src/guile
diff options
context:
space:
mode:
authorWojtek Kosior <koszko@koszko.org>2023-12-15 22:26:10 +0100
committerWojtek Kosior <koszko@koszko.org>2023-12-16 13:16:48 +0100
commitdac73785f73a91306a1c3eacbf04be720717ab76 (patch)
tree8636cfb50ec63d0e1e3d171cf3f723e1ff8769cd /src/guile
downloadcantius-dac73785f73a91306a1c3eacbf04be720717ab76.tar.gz
cantius-dac73785f73a91306a1c3eacbf04be720717ab76.zip
Initial commit.
Diffstat (limited to 'src/guile')
-rw-r--r--src/guile/Makefile.am20
-rw-r--r--src/guile/cantius.scm364
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))