Initial commit.

3 files changed, 196 insertions, 0 deletions

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))))