diff options
Diffstat (limited to '')
-rwxr-xr-x | tests/litmus.scm | 80 |
1 files changed, 80 insertions, 0 deletions
diff --git a/tests/litmus.scm b/tests/litmus.scm new file mode 100755 index 00000000..11d5fd9e --- /dev/null +++ b/tests/litmus.scm @@ -0,0 +1,80 @@ +#!/usr/bin/env bash +# -*- mode: scheme; geiser-scheme-implementation: guile -*- + +here=$(dirname $(realpath $0)) +. "$(dirname "$here")/env" + +exec $GUILE -e main -s "$0" "$@" +!# + +(use-modules (calp server webdav) + (ice-9 threads) + (ice-9 rdelim) + (web server) + (srfi srfi-1) + (srfi srfi-88)) + +;;; Commentary: +;;; Runs the external WebDAV test framework litmus [1], pointing it +;;; to a new instance of our webdav server. +;;; +;;; [1]: http://webdav.org/neon/litmus/ +;;; +;;; Code: + + +;;; NOTE this "page" is borrowed from (calp server server). +;;; Possibly rewrite so that module actually works as a module, +;;; And import it here + + +;; NOTE The default make-default-socket is broken for IPv6. +;; A patch has been submitted to the mailing list. 2020-03-31 +;; +;; This sets up the socket manually, and sends that to @code{http-open}. +(define* (make-default-socket/fixed family addr port) + (let ((sock (socket family SOCK_STREAM 0))) + (setsockopt sock SOL_SOCKET SO_REUSEADDR 1) + (bind sock family addr port) + sock)) + +(define* (setup-socket key: + (host #f) + (family AF_INET) + (addr (if host (inet-pton family host) + INADDR_LOOPBACK)) + (port 8080)) + (make-default-socket/fixed family addr port)) + + + +(define (start-server out) + (begin-thread + (let loop ((port 8102)) + (catch 'system-error + (lambda () + (let ((socket (setup-socket port: port))) + (format out "http://localhost:8102~%") + (force-output out) + (with-error-to-file "webdav.log" + (lambda () + (run-server webdav-handler 'http + `(socket: ,socket)))) + (format #t "Server closed~%"))) + (lambda (err proc fmt args data) + (if (= EADDRINUSE (car data)) + (loop (1+ port)) + (apply throw err proc fmt args data))))))) + + +(define (main args) + (define-values (in out) (car+cdr (pipe))) + (define scm (start-server out)) + (define uri-base (read-line in)) + (define suffix + (if (null? (cdr args)) + "" + (string-append "/" (cadr args)))) + (system* "litmus" (string-append uri-base suffix)) + + (cancel-thread scm)) |