Initial commit.

15 files changed, 813 insertions, 0 deletions

diff --git a/.dir-locals.el b/.dir-locals.el
new file mode 100644
index 0000000..266d78c
--- /dev/null
+++ b/.dir-locals.el
@@ -0,0 +1,8 @@
+;; SPDX-License-Identifier: CC0-1.0
+;;
+;; Copyright (C) 2023 Wojtek Kosior <koszko@koszko.org>
+
+((scheme-mode
+  .
+  ;; Add guile indentation hints
+  ((eval . (put 'start-stack 'scheme-indent-function 1)))))
diff --git a/.gitignore b/.gitignore
new file mode 100644
index 0000000..1be1f36
--- /dev/null
+++ b/.gitignore
@@ -0,0 +1,15 @@
+# SPDX-License-Identifier: CC0-1.0
+#
+# Copyright (C) 2023 Wojtek Kosior <koszko@koszko.org>
+
+*.go
+Makefile
+Makefile.in
+aclocal.m4
+autom4te.cache
+autotools-aux
+config.log
+config.status
+configure
+configure~
+cantius-*.tar.gz
diff --git a/.reuse/dep5 b/.reuse/dep5
new file mode 100644
index 0000000..73299db
--- /dev/null
+++ b/.reuse/dep5
@@ -0,0 +1,4 @@
+Format: https://www.debian.org/doc/packaging-manuals/copyright-format/1.0/
+Upstream-Name: Cantius
+Upstream-Contact: Wojtek Kosior <koszko@koszko.org>
+Source: https://git.koszko.org/cantius/about
diff --git a/LICENSES/CC0-1.0.txt b/LICENSES/CC0-1.0.txt
new file mode 100644
index 0000000..0e259d4
--- /dev/null
+++ b/LICENSES/CC0-1.0.txt
@@ -0,0 +1,121 @@
+Creative Commons Legal Code
+
+CC0 1.0 Universal
+
+    CREATIVE COMMONS CORPORATION IS NOT A LAW FIRM AND DOES NOT PROVIDE
+    LEGAL SERVICES. DISTRIBUTION OF THIS DOCUMENT DOES NOT CREATE AN
+    ATTORNEY-CLIENT RELATIONSHIP. CREATIVE COMMONS PROVIDES THIS
+    INFORMATION ON AN "AS-IS" BASIS. CREATIVE COMMONS MAKES NO WARRANTIES
+    REGARDING THE USE OF THIS DOCUMENT OR THE INFORMATION OR WORKS
+    PROVIDED HEREUNDER, AND DISCLAIMS LIABILITY FOR DAMAGES RESULTING FROM
+    THE USE OF THIS DOCUMENT OR THE INFORMATION OR WORKS PROVIDED
+    HEREUNDER.
+
+Statement of Purpose
+
+The laws of most jurisdictions throughout the world automatically confer
+exclusive Copyright and Related Rights (defined below) upon the creator
+and subsequent owner(s) (each and all, an "owner") of an original work of
+authorship and/or a database (each, a "Work").
+
+Certain owners wish to permanently relinquish those rights to a Work for
+the purpose of contributing to a commons of creative, cultural and
+scientific works ("Commons") that the public can reliably and without fear
+of later claims of infringement build upon, modify, incorporate in other
+works, reuse and redistribute as freely as possible in any form whatsoever
+and for any purposes, including without limitation commercial purposes.
+These owners may contribute to the Commons to promote the ideal of a free
+culture and the further production of creative, cultural and scientific
+works, or to gain reputation or greater distribution for their Work in
+part through the use and efforts of others.
+
+For these and/or other purposes and motivations, and without any
+expectation of additional consideration or compensation, the person
+associating CC0 with a Work (the "Affirmer"), to the extent that he or she
+is an owner of Copyright and Related Rights in the Work, voluntarily
+elects to apply CC0 to the Work and publicly distribute the Work under its
+terms, with knowledge of his or her Copyright and Related Rights in the
+Work and the meaning and intended legal effect of CC0 on those rights.
+
+1. Copyright and Related Rights. A Work made available under CC0 may be
+protected by copyright and related or neighboring rights ("Copyright and
+Related Rights"). Copyright and Related Rights include, but are not
+limited to, the following:
+
+  i. the right to reproduce, adapt, distribute, perform, display,
+     communicate, and translate a Work;
+ ii. moral rights retained by the original author(s) and/or performer(s);
+iii. publicity and privacy rights pertaining to a person's image or
+     likeness depicted in a Work;
+ iv. rights protecting against unfair competition in regards to a Work,
+     subject to the limitations in paragraph 4(a), below;
+  v. rights protecting the extraction, dissemination, use and reuse of data
+     in a Work;
+ vi. database rights (such as those arising under Directive 96/9/EC of the
+     European Parliament and of the Council of 11 March 1996 on the legal
+     protection of databases, and under any national implementation
+     thereof, including any amended or successor version of such
+     directive); and
+vii. other similar, equivalent or corresponding rights throughout the
+     world based on applicable law or treaty, and any national
+     implementations thereof.
+
+2. Waiver. To the greatest extent permitted by, but not in contravention
+of, applicable law, Affirmer hereby overtly, fully, permanently,
+irrevocably and unconditionally waives, abandons, and surrenders all of
+Affirmer's Copyright and Related Rights and associated claims and causes
+of action, whether now known or unknown (including existing as well as
+future claims and causes of action), in the Work (i) in all territories
+worldwide, (ii) for the maximum duration provided by applicable law or
+treaty (including future time extensions), (iii) in any current or future
+medium and for any number of copies, and (iv) for any purpose whatsoever,
+including without limitation commercial, advertising or promotional
+purposes (the "Waiver"). Affirmer makes the Waiver for the benefit of each
+member of the public at large and to the detriment of Affirmer's heirs and
+successors, fully intending that such Waiver shall not be subject to
+revocation, rescission, cancellation, termination, or any other legal or
+equitable action to disrupt the quiet enjoyment of the Work by the public
+as contemplated by Affirmer's express Statement of Purpose.
+
+3. Public License Fallback. Should any part of the Waiver for any reason
+be judged legally invalid or ineffective under applicable law, then the
+Waiver shall be preserved to the maximum extent permitted taking into
+account Affirmer's express Statement of Purpose. In addition, to the
+extent the Waiver is so judged Affirmer hereby grants to each affected
+person a royalty-free, non transferable, non sublicensable, non exclusive,
+irrevocable and unconditional license to exercise Affirmer's Copyright and
+Related Rights in the Work (i) in all territories worldwide, (ii) for the
+maximum duration provided by applicable law or treaty (including future
+time extensions), (iii) in any current or future medium and for any number
+of copies, and (iv) for any purpose whatsoever, including without
+limitation commercial, advertising or promotional purposes (the
+"License"). The License shall be deemed effective as of the date CC0 was
+applied by Affirmer to the Work. Should any part of the License for any
+reason be judged legally invalid or ineffective under applicable law, such
+partial invalidity or ineffectiveness shall not invalidate the remainder
+of the License, and in such case Affirmer hereby affirms that he or she
+will not (i) exercise any of his or her remaining Copyright and Related
+Rights in the Work or (ii) assert any associated claims and causes of
+action with respect to the Work, in either case contrary to Affirmer's
+express Statement of Purpose.
+
+4. Limitations and Disclaimers.
+
+ a. No trademark or patent rights held by Affirmer are waived, abandoned,
+    surrendered, licensed or otherwise affected by this document.
+ b. Affirmer offers the Work as-is and makes no representations or
+    warranties of any kind concerning the Work, express, implied,
+    statutory or otherwise, including without limitation warranties of
+    title, merchantability, fitness for a particular purpose, non
+    infringement, or the absence of latent or other defects, accuracy, or
+    the present or absence of errors, whether or not discoverable, all to
+    the greatest extent permissible under applicable law.
+ c. Affirmer disclaims responsibility for clearing rights of other persons
+    that may apply to the Work or any use thereof, including without
+    limitation any person's Copyright and Related Rights in the Work.
+    Further, Affirmer disclaims responsibility for obtaining any necessary
+    consents, permissions or other rights required for any use of the
+    Work.
+ d. Affirmer understands and acknowledges that Creative Commons is not a
+    party to this document and has no duty or obligation with respect to
+    this CC0 or use of the Work.
diff --git a/Makefile.am b/Makefile.am
new file mode 100644
index 0000000..3c78814
--- /dev/null
+++ b/Makefile.am
@@ -0,0 +1,13 @@
+# SPDX-License-Identifier: CC0-1.0
+#
+# Copyright (C) 2023 Wojtek Kosior <koszko@koszko.org>
+
+SUBDIRS = src/guile tests/guile
+
+EXTRA_DIST = \
+	LICENSES/CC0-1.0.txt \
+	.reuse/dep5 \
+	bootstrap \
+	.dir-locals.el \
+	.gitignore \
+	README.md.license
diff --git a/README.md b/README.md
new file mode 100644
index 0000000..8120a3a
--- /dev/null
+++ b/README.md
@@ -0,0 +1,33 @@
+# Cantius
+
+Software freedom empowers sharing.  Let's dedicate our libre software projects
+to saints known for fostering sharing!
+
+This Guile web server library is dedicated to St. John Cantius, a polish priest
+and university professor of the 15th century.  He became well known for caring
+for the poor — stories survived about him giving away his meal and his shoes but
+also about his penitents being told to give exceptionally huge alms for penance.
+
+## What does this library do?
+
+Cantius builds upon the `(fibers web server)` to provide a more complete tooling
+for building websites.
+
+## Use examples
+
+Please look into the test suite in `tests/guile/`.
+
+## Building & installation
+
+This software has a Guix package definition in Wojtek's [personal
+channel](https://git.koszko.org/guix/about).  That can serve you as a point of
+reference.
+
+## Copying
+
+The source code of this package is available under CC0 v1.0.  The repository is
+kept compliant with the [REUSE](https://reuse.software/) specification, version
+3.0.
+
+Note that the uderlying GNU Guile language is covered by the GNU GPL and hence
+any binary redistribution of *Cantius* shall be covered by it as well.
diff --git a/README.md.license b/README.md.license
new file mode 100644
index 0000000..e54bf4d
--- /dev/null
+++ b/README.md.license
@@ -0,0 +1,3 @@
+SPDX-License-Identifier: CC0-1.0
+
+Copyright (C) 2023 Wojtek Kosior <koszko@koszko.org>
diff --git a/autotools-aux/config.rpath b/autotools-aux/config.rpath
new file mode 100644
index 0000000..e69de29
--- /dev/null
+++ b/autotools-aux/config.rpath
diff --git a/bootstrap b/bootstrap
new file mode 100755
index 0000000..0040cd3
--- /dev/null
+++ b/bootstrap
@@ -0,0 +1,8 @@
+#!/bin/sh
+
+# SPDX-License-Identifier: CC0-1.0
+#
+# Copyright (C) 2023 Wojtek Kosior <koszko@koszko.org>
+
+cd "$(dirname "$0")"
+autoreconf --install
diff --git a/configure.ac b/configure.ac
new file mode 100644
index 0000000..5f07bd2
--- /dev/null
+++ b/configure.ac
@@ -0,0 +1,28 @@
+# SPDX-License-Identifier: CC0-1.0
+#
+# Copyright (C) 2023 Wojtek Kosior <koszko@koszko.org>
+
+AC_INIT([cantius], [0.1], [koszko@koszko.org])
+
+AC_CONFIG_SRCDIR([src/guile/cantius.scm])
+
+m4_pattern_forbid([^GUILE_])
+m4_pattern_allow([^GUILE_PKG_ERRORS$])
+
+GUILE_PKG([3.0])
+GUILE_PROGS
+
+GUILE_MODULE_REQUIRED([fibers])
+GUILE_MODULE_REQUIRED([srfi srfi-146])
+GUILE_MODULE_REQUIRED([srfi srfi-128])
+
+AC_PATH_PROG([GUILE_TEST_DRIVER], [guile-test-driver])
+
+AC_CONFIG_AUX_DIR([autotools-aux])
+
+AM_INIT_AUTOMAKE([-Wall -Werror foreign])
+
+AC_CONFIG_FILES([Makefile src/guile/Makefile tests/guile/Makefile])
+AX_ADD_GUILE_PRE_INST_ENV()
+
+AC_OUTPUT
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))
diff --git a/tests/guile/.dir-locals.el b/tests/guile/.dir-locals.el
new file mode 100644
index 0000000..6a1a323
--- /dev/null
+++ b/tests/guile/.dir-locals.el
@@ -0,0 +1,8 @@
+;; SPDX-License-Identifier: CC0-1.0
+;;
+;; Copyright (C) 2023 Wojtek Kosior <koszko@koszko.org>
+
+((scheme-mode
+  .
+  ;; Add guile indentation hints
+  ((eval . (put 'tu:test-group 'scheme-indent-function 1)))))
diff --git a/tests/guile/Makefile.am b/tests/guile/Makefile.am
new file mode 100644
index 0000000..36d4eba
--- /dev/null
+++ b/tests/guile/Makefile.am
@@ -0,0 +1,27 @@
+# SPDX-License-Identifier: CC0-1.0
+#
+# Copyright (C) 2023 Wojtek Kosior <koszko@koszko.org>
+
+GUILE_SOURCE_FILES = \
+	$(PACKAGE)-test.scm
+
+GUILE_OBJECT_FILES = $(GUILE_SOURCE_FILES:.scm=.go)
+
+
+TEST_EXTENSIONS = .scm
+
+SCM_LOG_DRIVER = $(top_builddir)/pre-inst-env $(GUILE_TEST_DRIVER)
+
+TESTS = $(GUILE_SOURCE_FILES)
+
+
+dist_noinst_DATA = $(GUILE_SOURCE_FILES)
+
+check_DATA = $(GUILE_OBJECT_FILES)
+
+MOSTLYCLEANFILES = $(GUILE_OBJECT_FILES)
+
+.scm.go:
+	$(top_builddir)/pre-inst-env $(GUILD) compile --output=$@ $<
+
+EXTRA_DIST=.dir-locals.el
diff --git a/tests/guile/cantius-test.scm b/tests/guile/cantius-test.scm
new file mode 100644
index 0000000..bae8db8
--- /dev/null
+++ b/tests/guile/cantius-test.scm
@@ -0,0 +1,161 @@
+;;; SPDX-License-Identifier: CC0-1.0
+;;;
+;;; Copyright (C) 2023 Wojtek Kosior <koszko@koszko.org>
+
+(use-modules ((srfi srfi-8) #:select (receive))
+             ((srfi srfi-26) #:select (cut))
+             ((srfi srfi-34) #:select (guard raise))
+             ((ice-9 safe-r5rs) #:select (null-environment))
+             ((web client) #:select (open-socket-for-uri http-get))
+             ((web response) #:prefix rsp:)
+             ((web uri) #:prefix uri:)
+             ((myra-test-utils) #:prefix tu:))
+
+(define (make-env)
+  (let ((env (null-environment 5)))
+    (module-use! env (resolve-interface '(guile)))
+    env))
+
+(define (test-env name)
+  (resolve-module `(cantius-test ,name)))
+
+(define (open-socket-with-timeout uri timeout)
+  (let ((start-time (current-time)))
+    (let loop ()
+      (guard (cnd ((> (current-time) (+ start-time timeout))
+                   (raise cnd))
+                  (#t
+                   (sleep 1)
+                   (loop)))
+        (open-socket-for-uri uri)))))
+
+(tu:test-group "nonfree-site"
+  (tu:test-assert
+   (or (eval '(begin
+                (define-module (cantius-test nonfree-site)
+                  #:use-module ((srfi srfi-18) #:select
+                                (make-thread thread-terminate! thread-yield!
+                                 thread-start!))
+                  #:use-module (cantius))
+
+                (define sock-port
+                  #f))
+             (make-env))))
+
+  (tu:test-assert
+   (or (eval '(begin
+                (define %my-endset
+                  (endset))
+
+                (define-endpoint %my-endset about-ms
+                  ("cool-companies" "ms" "about") ()
+                  (values (build-response*)
+                          "Microsoft is my favorite company.  I started using
+ Microsoft at the age of..."))
+
+                (define-endpoint %my-endset broken
+                  ("cool-companies" "ms" "product-list") ()
+                  (/ 1 0))
+
+                (define-endpoint %my-endset drm-wiki
+                  ("drm-wiki" ,(string-append "dev" "ices") . some-path) ()
+                  (values (build-response*)
+                          (string-join (cons "page for:" some-path))))
+
+                (define-endpoint %my-endset about-google
+                  ,(list "cool-companies" "google" "about")
+                  ((redirect/normalize-path? #f)
+                   (redirect/remove-query? #f))
+                  (values (build-response*)
+                          "Google provides the best services in the world..."))
+
+                (define server-sock
+                  (socket PF_INET SOCK_STREAM 0))
+
+                (bind server-sock AF_INET INADDR_LOOPBACK 0)
+
+                (define sock-port
+                  (sockaddr:port (getsockname server-sock)))
+
+                (define server-thread
+                  (make-thread
+                   (lambda ()
+                     (run-cantius %my-endset #:socket server-sock))))
+
+                (thread-start! server-thread)
+
+                (thread-yield!))
+             (test-env 'nonfree-site))
+       #t))
+
+  (define (get path)
+    (false-if-exception
+     (let* ((sock-port (eval 'sock-port (test-env 'nonfree-site)))
+            (client-sock (open-socket-with-timeout
+                          (format #f "http://localhost:~a" sock-port)
+                          5)))
+       (dynamic-wind
+         (const #f)
+         (lambda ()
+           (receive (response response-body)
+               (http-get (string-append "http://dummy" path) #:port client-sock)
+             (list response response-body)))
+         (lambda ()
+           (close client-sock))))))
+
+  (tu:test-group "ms-about"
+    (define ms-result
+      (get "/cool-companies/ms/about"))
+
+    (tu:test-eqv 200 (rsp:response-code (car ms-result)))
+
+    (tu:test-equal '(text/plain (charset . "utf-8"))
+                   (rsp:response-content-type (car ms-result)))
+
+    (tu:test-assert (string-prefix? "Microsoft is my favorite company"
+                                    (cadr ms-result))))
+
+  (for-each
+   (lambda (path)
+     (tu:test-group "ms-about-auto-redirect"
+       (define ms-redirect-result
+         (get path))
+
+       (tu:test-eqv 301 (rsp:response-code (car ms-redirect-result)))
+
+       (tu:test-equal "/cool-companies/ms/about"
+                      (uri:uri-path
+                       (rsp:response-location (car ms-redirect-result))))))
+   '("/cool-companies//ms/about" "/cool-companies/ms/about?a=b"))
+
+  (tu:test-group "error-500"
+    (define error-500-result
+      (get "/cool-companies/ms/product-list"))
+
+    (tu:test-eqv 500 (rsp:response-code (car error-500-result)))
+
+    (tu:test-assert (string-contains (cadr error-500-result) "Backtrace")))
+
+  (tu:test-group "error-404"
+    (define error-404-result
+      (get "/cool-companies/amazon//about?c=d"))
+
+    (tu:test-eqv 404 (rsp:response-code (car error-404-result))))
+
+  (tu:test-group "drm-wiki"
+    (define ipad-result
+      (get "/drm-wiki/devices/apple/ipad"))
+
+    (tu:test-equal "page for: apple ipad" (cadr ipad-result)))
+
+  (tu:test-group "about-google"
+    (define google-result
+      (get "/cool-companies///google/about?e=f"))
+
+    (tu:test-eqv 200 (rsp:response-code (car google-result)))
+
+    (tu:test-assert (string-prefix? "Google provides" (cadr google-result))))
+
+  (tu:test-assert (eval '(begin (thread-terminate! server-thread)
+                                (close server-sock))
+                        (test-env 'nonfree-site))))