mirror of
git://git.savannah.gnu.org/guix/guix-cuirass.git
synced 2023-12-14 06:03:04 +01:00
http: Use our own 'fiberized' web server backend.
* src/web/server/fiberized.scm: New file. * Makefile.am (dist_pkgmodule_DATA): Add it. * src/cuirass/http.scm (run-cuirass-server): Use it.
This commit is contained in:
parent
c2cbee8b4f
commit
77769c29e7
3 changed files with 179 additions and 2 deletions
|
@ -37,7 +37,8 @@ dist_pkgmodule_DATA = \
|
|||
src/cuirass/http.scm \
|
||||
src/cuirass/logging.scm \
|
||||
src/cuirass/ui.scm \
|
||||
src/cuirass/utils.scm
|
||||
src/cuirass/utils.scm \
|
||||
src/web/server/fiberized.scm
|
||||
|
||||
nodist_pkgmodule_DATA = \
|
||||
src/cuirass/config.scm
|
||||
|
|
|
@ -183,7 +183,12 @@
|
|||
(address (inet-ntop (hostent:addrtype host-info)
|
||||
(car (hostent:addr-list host-info)))))
|
||||
(log-message "listening on ~A:~A" address port)
|
||||
|
||||
;; Here we use our own web backend, call 'fiberized'. We cannot use the
|
||||
;; 'fibers' backend that comes with Fibers 1.0.0 because it does its own
|
||||
;; thread creations and calls 'run-fibers' by itself, which isn't
|
||||
;; necessary here (and harmful).
|
||||
(run-server url-handler
|
||||
'fibers ;the fibers web backend
|
||||
'fiberized
|
||||
`(#:host ,address #:port ,port)
|
||||
db)))
|
||||
|
|
171
src/web/server/fiberized.scm
Normal file
171
src/web/server/fiberized.scm
Normal file
|
@ -0,0 +1,171 @@
|
|||
;;; Web I/O: Non-blocking HTTP
|
||||
|
||||
;; Copyright (C) 2012, 2018 Free Software Foundation, Inc.
|
||||
|
||||
;; This library is free software; you can redistribute it and/or
|
||||
;; modify it under the terms of the GNU Lesser General Public
|
||||
;; License as published by the Free Software Foundation; either
|
||||
;; version 3 of the License, or (at your option) any later version.
|
||||
;;
|
||||
;; This library is distributed in the hope that it will be useful,
|
||||
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
||||
;; Lesser General Public License for more details.
|
||||
;;
|
||||
;; You should have received a copy of the GNU Lesser General Public
|
||||
;; License along with this library; if not, write to the Free Software
|
||||
;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
|
||||
;; 02110-1301 USA
|
||||
|
||||
;;; Commentary:
|
||||
;;;
|
||||
;;; This is the non-blocking HTTP implementation of the (web server)
|
||||
;;; interface.
|
||||
;;;
|
||||
;;; It is a modified version of (web server fibers) from Fibers 1.0.0 that
|
||||
;;; does not create new threads and does not call 'run-fibers'. Instead it
|
||||
;;; expects to be running directly in a fiberized program.
|
||||
;;;
|
||||
;;; (Modifications by Ludovic Courtès, 2018-01.)
|
||||
;;;
|
||||
;;; Code:
|
||||
|
||||
(define-module (web server fiberized)
|
||||
#:use-module ((srfi srfi-1) #:select (fold))
|
||||
#:use-module (srfi srfi-9)
|
||||
#:use-module (web http)
|
||||
#:use-module (web request)
|
||||
#:use-module (web response)
|
||||
#:use-module (web server)
|
||||
#:use-module (ice-9 binary-ports)
|
||||
#:use-module (ice-9 match)
|
||||
#:use-module (fibers)
|
||||
#:use-module (fibers channels))
|
||||
|
||||
(define (make-default-socket family addr port)
|
||||
(let ((sock (socket PF_INET SOCK_STREAM 0)))
|
||||
(setsockopt sock SOL_SOCKET SO_REUSEADDR 1)
|
||||
(fcntl sock F_SETFD FD_CLOEXEC)
|
||||
(bind sock family addr port)
|
||||
(fcntl sock F_SETFL (logior O_NONBLOCK (fcntl sock F_GETFL)))
|
||||
sock))
|
||||
|
||||
(define-record-type <server>
|
||||
(make-server request-channel)
|
||||
server?
|
||||
(request-channel server-request-channel))
|
||||
|
||||
;; -> server
|
||||
(define* (open-server #:key
|
||||
(host #f)
|
||||
(family AF_INET)
|
||||
(addr (if host
|
||||
(inet-pton family host)
|
||||
INADDR_LOOPBACK))
|
||||
(port 8080)
|
||||
(socket (make-default-socket family addr port)))
|
||||
;; We use a large backlog by default. If the server is suddenly hit
|
||||
;; with a number of connections on a small backlog, clients won't
|
||||
;; receive confirmation for their SYN, leading them to retry --
|
||||
;; probably successfully, but with a large latency.
|
||||
(listen socket 1024)
|
||||
(fcntl socket F_SETFL (logior O_NONBLOCK (fcntl socket F_GETFL)))
|
||||
(sigaction SIGPIPE SIG_IGN)
|
||||
(let ((request-channel (make-channel)))
|
||||
(spawn-fiber
|
||||
(lambda ()
|
||||
(socket-loop socket request-channel)))
|
||||
(make-server request-channel)))
|
||||
|
||||
(define (bad-request msg . args)
|
||||
(throw 'bad-request msg args))
|
||||
|
||||
(define (keep-alive? response)
|
||||
(let ((v (response-version response)))
|
||||
(and (or (< (response-code response) 400)
|
||||
(= (response-code response) 404))
|
||||
(case (car v)
|
||||
((1)
|
||||
(case (cdr v)
|
||||
((1) (not (memq 'close (response-connection response))))
|
||||
((0) (memq 'keep-alive (response-connection response)))))
|
||||
(else #f)))))
|
||||
|
||||
(define (client-loop client have-request)
|
||||
;; Always disable Nagle's algorithm, as we handle buffering
|
||||
;; ourselves.
|
||||
(setsockopt client IPPROTO_TCP TCP_NODELAY 1)
|
||||
(setvbuf client 'block 1024)
|
||||
(with-throw-handler #t
|
||||
(lambda ()
|
||||
(let ((response-channel (make-channel)))
|
||||
(let loop ()
|
||||
(cond
|
||||
((eof-object? (lookahead-u8 client))
|
||||
(close-port client))
|
||||
(else
|
||||
(call-with-values
|
||||
(lambda ()
|
||||
(catch #t
|
||||
(lambda ()
|
||||
(let* ((request (read-request client))
|
||||
(body (read-request-body request)))
|
||||
(have-request response-channel request body)))
|
||||
(lambda (key . args)
|
||||
(display "While reading request:\n" (current-error-port))
|
||||
(print-exception (current-error-port) #f key args)
|
||||
(values (build-response #:version '(1 . 0) #:code 400
|
||||
#:headers '((content-length . 0)))
|
||||
#vu8()))))
|
||||
(lambda (response body)
|
||||
(write-response response client)
|
||||
(when body
|
||||
(put-bytevector client body))
|
||||
(force-output client)
|
||||
(if (and (keep-alive? response)
|
||||
(not (eof-object? (peek-char client))))
|
||||
(loop)
|
||||
(close-port client)))))))))
|
||||
(lambda (k . args)
|
||||
(catch #t
|
||||
(lambda () (close-port client))
|
||||
(lambda (k . args)
|
||||
(display "While closing port:\n" (current-error-port))
|
||||
(print-exception (current-error-port) #f k args))))))
|
||||
|
||||
(define (socket-loop socket request-channel)
|
||||
(define (have-request response-channel request body)
|
||||
(put-message request-channel (vector response-channel request body))
|
||||
(match (get-message response-channel)
|
||||
(#(response body)
|
||||
(values response body))))
|
||||
(let loop ()
|
||||
(match (accept socket (logior SOCK_NONBLOCK SOCK_CLOEXEC))
|
||||
((client . sockaddr)
|
||||
(spawn-fiber (lambda () (client-loop client have-request))
|
||||
#:parallel? #t)
|
||||
(loop)))))
|
||||
|
||||
;; -> (client request body | #f #f #f)
|
||||
(define (server-read server)
|
||||
(match (get-message (server-request-channel server))
|
||||
(#(response-channel request body)
|
||||
(let ((client response-channel))
|
||||
(values client request body)))))
|
||||
|
||||
;; -> 0 values
|
||||
(define (server-write server client response body)
|
||||
(let ((response-channel client))
|
||||
(put-message response-channel (vector response body)))
|
||||
(values))
|
||||
|
||||
;; -> unspecified values
|
||||
(define (close-server server)
|
||||
;; FIXME: We should terminate the 'socket-loop' fiber somehow.
|
||||
*unspecified*)
|
||||
|
||||
(define-server-impl fiberized
|
||||
open-server
|
||||
server-read
|
||||
server-write
|
||||
close-server)
|
Loading…
Reference in a new issue