82 lines
2.2 KiB
Scheme
82 lines
2.2 KiB
Scheme
(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)
|
|
(web uri))
|
|
|
|
(define mime-types
|
|
'(("html" . (text/html))
|
|
("css" . (text/css))
|
|
("js" . (application/javascript))
|
|
("f" . (text/plain))
|
|
("ws" . (text/plain))
|
|
("png" . (image/png))))
|
|
|
|
(define (mime-type path)
|
|
(let* ((dot (string-rindex path #\.))
|
|
(ext (when dot (substring path (1+ dot)))))
|
|
(or (assoc-ref mime-types ext) "application/octet-stream")))
|
|
|
|
(define headers
|
|
'((cross-origin-opener-policy . "same-origin")
|
|
(cross-origin-embedder-policy . "require-corp")
|
|
(cache-control . (no-store no-cache must-revalidate))))
|
|
|
|
(define (is-dir? path)
|
|
(eq? 'directory (stat:type (stat path))))
|
|
|
|
(define (request-path request)
|
|
(let ((path (string-append "." (uri-path (request-uri request)))))
|
|
(cond ((not (file-exists? path)) #nil)
|
|
((is-dir? path) (string-append path "index.html"))
|
|
(#t path))))
|
|
|
|
(define (file-handler request body)
|
|
(let ((path (request-path request)))
|
|
(if path
|
|
(values (cons `(content-type . ,(mime-type path)) headers)
|
|
(get-bytevector-all (open-input-file path)))
|
|
(values (build-response #:code 404) #f))))
|
|
|
|
(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))
|