summaryrefslogtreecommitdiff
path: root/tests/testlib.scm
diff options
context:
space:
mode:
authorPeter Bex <peter@more-magic.net>2018-07-29 19:39:39 +0200
committerPeter Bex <peter@more-magic.net>2018-07-29 19:39:39 +0200
commit776d00c6cd7cabc16f13a18eee54fa2f3f36bf21 (patch)
treee965a2808a234d83c8a31ef0965f73784db1bac8 /tests/testlib.scm
downloadspiffy-776d00c6cd7cabc16f13a18eee54fa2f3f36bf21.tar.gz
Port to CHICKEN 5
Diffstat (limited to 'tests/testlib.scm')
-rw-r--r--tests/testlib.scm108
1 files changed, 108 insertions, 0 deletions
diff --git a/tests/testlib.scm b/tests/testlib.scm
new file mode 100644
index 0000000..f706753
--- /dev/null
+++ b/tests/testlib.scm
@@ -0,0 +1,108 @@
+(import (chicken condition) (chicken format) (chicken io)
+ (chicken process-context) (chicken process-context posix)
+ (chicken tcp) (chicken process) (chicken file posix)
+ uri-common intarweb srfi-18)
+
+(server-port (string->number
+ (or (get-environment-variable "SPIFFY_TEST_PORT") "8080")))
+
+(define (check-port)
+ (let ((listener #f)
+ (msg (sprintf "Checking port ~A is available" (server-port))))
+ (handle-exceptions exn (void)
+ (set! listener (tcp-listen (server-port))))
+ (test-assert msg (tcp-listener? listener))
+ (tcp-close listener)))
+
+(define spiffy-pid #f)
+
+(define (can-connect?)
+ (handle-exceptions exn #f
+ (receive (in out)
+ (tcp-connect "127.0.0.1" (server-port))
+ (close-input-port in)
+ (close-output-port out)
+ #t)))
+
+(define (wait-for-spiffy times)
+ (if (zero? times)
+ #f
+ (begin (thread-sleep! 1) (or (can-connect?) (wait-for-spiffy (sub1 times))))))
+
+(define NOT-FOUND "file not found")
+
+(define (send-string/code code reason string)
+ (current-response
+ (update-response (current-response)
+ code: code reason: reason))
+ (write-logged-response)
+ (display string (response-port (current-response))))
+
+(define response-error? #f)
+
+(define (start-spiffy)
+ (check-port)
+ (set! spiffy-pid
+ (process-fork
+ (lambda ()
+ (parameterize ((root-path "./testweb")
+ (error-log (get-environment-variable "SPIFFY_ERROR_LOG"))
+ (handle-not-found
+ (lambda (p)
+ (send-string/code 404 "Not found" NOT-FOUND)))
+ (handle-exception
+ (lambda (exn chain)
+ (let ((m ((condition-property-accessor 'exn 'message) exn))
+ (a ((condition-property-accessor 'exn 'arguments) exn)))
+ (log-to (error-log) (build-error-message exn chain #t))
+ (set! response-error? #t)
+ (send-string/code 500 "Internal server error"
+ (if (and a (not (null? a)))
+ (sprintf "~A ~A" m a)
+ m))))))
+ (start-server)))))
+ (on-exit (lambda _ (process-signal spiffy-pid)))
+ (test-assert "Spiffy responds in 3 seconds" (wait-for-spiffy 3))
+ (void))
+
+;;;; test tools
+
+(define (fetch-file file host #!key (send-headers `((host (,host . ,(server-port))))) (get-headers #f) (version '(1 0)) (method 'GET) (absolute-uri #t))
+ (set! response-error? #f)
+ (let ((uri (uri-reference (if absolute-uri
+ (sprintf "http://~A:~A~A" host (server-port) file)
+ file))))
+ (receive (in out)
+ (tcp-connect "127.0.0.1" (server-port))
+ (let* ((req-headers (headers send-headers))
+ (req (make-request method: method uri: uri
+ major: (car version) minor: (cadr version)
+ headers: req-headers port: out)))
+ (write-request req)
+ (let* ((resp (read-response in))
+ (str (read-string (header-value 'content-length (response-headers resp)) in)))
+ (close-output-port out)
+ (close-input-port in)
+ (if get-headers
+ (response-headers resp)
+ (list (response-code resp) str)))))))
+
+(define-syntax test-response
+ (syntax-rules ()
+ ((_ ?text (?code-expected ?contents-expected) ?args ...)
+ (test ?text (list ?code-expected ?contents-expected) (fetch-file ?args ...)))
+ ((_ ?text ?code-expected ?args ...)
+ (test ?text ?code-expected (car (fetch-file ?args ...))))))
+
+(define-syntax test-header
+ (syntax-rules ()
+ ((_ ?text ?header-name (?header-values ...) ?args ...)
+ (test ?text `(?header-values ...)
+ (header-values `?header-name
+ (fetch-file ?args ... get-headers: #t))))))
+
+;; Create an uri for this test server, which is needed because its
+;; port may be overridden.
+(define (testserver-uri str)
+ (let ((ref (uri-reference str)))
+ (update-uri ref port: (server-port))))