Port to CHICKEN 5

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