diff --git a/server.scm b/server.scm index c54589c..f2a3db4 100644 --- a/server.scm +++ b/server.scm @@ -1,5 +1,12 @@ +(define-module (server) + #:export (run start stop main)) + (use-modules + (ice-9 atomic) (ice-9 binary-ports) + (ice-9 threads) + (srfi srfi-9) + (web client) (web server) (web request) (web response) @@ -38,6 +45,38 @@ (if path (values (cons `(content-type . ,(mime-type path)) headers) (get-bytevector-all (open-input-file path))) - (values (build-response #:code 404) "")))) + (values (build-response #:code 404) #f)))) -(run-server file-handler) +(define* (run #:key (port 8080)) + (run-server file-handler 'http `(#:port ,port))) + +(define-record-type + (make-handle close-flag thread port) + handle? + (close-flag handle-close-flag) + (thread handle-thread) + (port handle-port)) + +(define (serve impl server should-close) + (let loop () + (unless (atomic-box-ref should-close) + (serve-one-client file-handler impl server '()) + (loop))) + (close-server impl server)) + +(define* (start #:key (port 8080)) + (let* ((impl (lookup-server-impl 'http)) + (server (open-server impl `(#:port ,port))) + (should-close (make-atomic-box #f)) + (thread + (call-with-new-thread + (lambda () (serve impl server should-close))))) + (make-handle should-close thread port))) + +(define (stop handle) + (atomic-box-set! (handle-close-flag handle) #t) + (http-request (format #f "http://localhost:~a/" (handle-port handle))) + (join-thread (handle-thread handle))) + +(when (string=? (basename (current-filename)) (car (command-line))) + (run))