Modify server.scm so it can be loaded as a module
This commit is contained in:
43
server.scm
43
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 <handle>
|
||||
(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))
|
||||
|
||||
Reference in New Issue
Block a user