diff options
author | Hugo Hörnquist <hugo@lysator.liu.se> | 2023-04-18 18:39:17 +0200 |
---|---|---|
committer | Hugo Hörnquist <hugo@lysator.liu.se> | 2023-04-18 18:39:17 +0200 |
commit | 44bc2fce13048396c1aa002f4eb6fa7b76db796b (patch) | |
tree | 072bbda518fd93247f50e00b3f037502f4861c3c | |
parent | Move test runner to library. (diff) | |
download | calp-44bc2fce13048396c1aa002f4eb6fa7b76db796b.tar.gz calp-44bc2fce13048396c1aa002f4eb6fa7b76db796b.tar.xz |
Move code for finding an available socket.
Diffstat (limited to '')
-rw-r--r-- | module/calp/server/server.scm | 18 | ||||
-rw-r--r-- | module/calp/server/socket.scm | 48 | ||||
-rwxr-xr-x | tests/litmus.scm | 47 |
3 files changed, 56 insertions, 57 deletions
diff --git a/module/calp/server/server.scm b/module/calp/server/server.scm index 04d33ba5..4c5a0886 100644 --- a/module/calp/server/server.scm +++ b/module/calp/server/server.scm @@ -4,29 +4,13 @@ :use-module ((calp server routes) :select (make-make-routes)) :use-module (ice-9 threads) :use-module (srfi srfi-88) + :use-module (calp server socket) :export (start-server)) ;;; TODO Do I really want this hardcoded here? (define handler (make-make-routes)) -;; 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 open-params) (run-server handler diff --git a/module/calp/server/socket.scm b/module/calp/server/socket.scm new file mode 100644 index 00000000..990adfa6 --- /dev/null +++ b/module/calp/server/socket.scm @@ -0,0 +1,48 @@ +(define-module (calp server socket) + :use-module (srfi srfi-88) + :use-module (web server) + :export (setup-socket + run-at-any-port) + ) + +;; 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* (run-at-any-port handler key: + (min-port 8081) + msg-port) + (unless msg-port + (scm-error 'misc-error "run-at-any-port" + "msg-port required" + '() #f)) + (let loop ((port min-port)) + (catch 'system-error + (lambda () + (let ((socket (setup-socket port: port))) + (let ((addr (format #f "http://localhost:~a~%" port))) + (display addr msg-port) + (force-output msg-port) + (format #t "Server started at ~s~%" addr) + (run-server 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)))))) diff --git a/tests/litmus.scm b/tests/litmus.scm index 11d5fd9e..477c5946 100755 --- a/tests/litmus.scm +++ b/tests/litmus.scm @@ -8,9 +8,9 @@ exec $GUILE -e main -s "$0" "$@" !# (use-modules (calp server webdav) + (calp server socket) (ice-9 threads) (ice-9 rdelim) - (web server) (srfi srfi-1) (srfi srfi-88)) @@ -23,48 +23,15 @@ exec $GUILE -e main -s "$0" "$@" ;;; 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))))))) + (with-error-to-file "webdav.log" + (lambda () + (run-at-any-port + webdav-handler + min-port: 8102 + msg-port: out))))) (define (main args) |