-(define %http-server-socket
- ;; Socket used by the Web server.
- (catch 'system-error
- (lambda ()
- (let ((sock (socket PF_INET SOCK_STREAM 0)))
- (setsockopt sock SOL_SOCKET SO_REUSEADDR 1)
- (bind sock
- (make-socket-address AF_INET INADDR_LOOPBACK
- %http-server-port))
- sock))
- (lambda args
- (let ((err (system-error-errno args)))
- (format (current-error-port)
- "warning: cannot run Web server for tests: ~a~%"
- (strerror err))
- #f))))
-
-(define (http-write server client response body)
- "Write RESPONSE."
- (let* ((response (write-response response client))
- (port (response-port response)))
- (cond
- ((not body)) ;pass
- (else
- (write-response-body response body)))
- (close-port port)
- (quit #t) ;exit the server thread
- (values)))
-
-;; Mutex and condition variable to synchronize with the HTTP server.
-(define %http-server-lock (make-mutex))
-(define %http-server-ready (make-condition-variable))
-
-(define (http-open . args)
- "Start listening for HTTP requests and signal %HTTP-SERVER-READY."
- (with-mutex %http-server-lock
- (let ((result (apply (@@ (web server http) http-open) args)))
- (signal-condition-variable %http-server-ready)
- result)))
-
-(define-server-impl stub-http-server
- ;; Stripped-down version of Guile's built-in HTTP server.
- http-open
- (@@ (web server http) http-read)
- http-write
- (@@ (web server http) http-close))
-
-(define (call-with-http-server code thunk)
- "Call THUNK with an HTTP server running and returning CODE on HTTP
-requests."
- (define (server-body)
- (define (handle request body)
- (values (build-response #:code code
- #:reason-phrase "Such is life")
- "Hello, world."))
-
- (catch 'quit
- (lambda ()
- (run-server handle stub-http-server
- `(#:socket ,%http-server-socket)))
- (const #t)))
-
- (with-mutex %http-server-lock
- (let ((server (make-thread server-body)))
- (wait-condition-variable %http-server-ready %http-server-lock)
- ;; Normally SERVER exits automatically once it has received a request.
- (thunk))))
-
-(define-syntax-rule (with-http-server code body ...)
- (call-with-http-server code (lambda () body ...)))