diff options
Diffstat (limited to 'tests/guile')
| -rw-r--r-- | tests/guile/.dir-locals.el | 8 | ||||
| -rw-r--r-- | tests/guile/Makefile.am | 27 | ||||
| -rw-r--r-- | tests/guile/cantius-test.scm | 161 |
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)))) |