[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] GNU Guile branch, master, updated. release_1-9-13-121-g4
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] GNU Guile branch, master, updated. release_1-9-13-121-g462a1a0 |
|
Date: |
Fri, 03 Dec 2010 14:30:26 +0000 |
This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".
http://git.savannah.gnu.org/cgit/guile.git/commit/?id=462a1a04cf256a9f995721b5d210d7438b3fc89b
The branch, master has been updated
via 462a1a04cf256a9f995721b5d210d7438b3fc89b (commit)
via 51c1dba88a62e3f1a1de3fc27a158a6d48bd379b (commit)
via 6f81b18abed11b7a2dd1dad15d8281ed7036b602 (commit)
from 0d4e6ca38f1c51f5f92effc7d97c8b69eb85d071 (commit)
Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.
- Log -----------------------------------------------------------------
commit 462a1a04cf256a9f995721b5d210d7438b3fc89b
Author: Andy Wingo <address@hidden>
Date: Fri Dec 3 15:31:57 2010 +0100
(web server) punts keep-alive to impls; http server uses (ice-9 poll)
* module/web/server.scm: Rewrite to remove the extra "keep-alive"
parameter. Instead, since the server is an essentially stateful
object, have clients that want to do keep-alive manage that set as
part of the server state. Also avoids imposing a particular data
structure on the server implementation.
* module/web/server/http.scm: Adapt to the new server interface. Also,
use a poll set instead of select and lists. Makes handling 1000
clients at a time much more possible.
commit 51c1dba88a62e3f1a1de3fc27a158a6d48bd379b
Author: Andy Wingo <address@hidden>
Date: Fri Dec 3 15:17:35 2010 +0100
ASYNC_TICK after catching EINTR in SCM_SYSCALL
* libguile/_scm.h (SCM_SYSCALL): As in scm_syserror, do a SCM_ASYNC_TICK
before resuming the syscall after an EINTR.
commit 6f81b18abed11b7a2dd1dad15d8281ed7036b602
Author: Andy Wingo <address@hidden>
Date: Fri Dec 3 13:09:43 2010 +0100
add (ice-9 poll), a poll wrapper
* libguile/poll.c:
* libguile/poll.h:
* module/ice-9/poll.scm: New module, (ice-9 poll).
* module/Makefile.am:
* libguile/init.c:
* libguile/Makefile.am: Adapt.
* configure.ac: Check for poll.h and poll.
-----------------------------------------------------------------------
Summary of changes:
configure.ac | 5 +-
libguile/Makefile.am | 2 +
libguile/_scm.h | 29 ++++++-
libguile/init.c | 2 +
libguile/poll.c | 146 ++++++++++++++++++++++++++++++++++
libguile/{gdbint.h => poll.h} | 12 +--
module/Makefile.am | 1 +
module/ice-9/poll.scm | 175 +++++++++++++++++++++++++++++++++++++++++
module/web/server.scm | 62 +++++----------
module/web/server/http.scm | 169 +++++++++++++++++++++++-----------------
10 files changed, 478 insertions(+), 125 deletions(-)
create mode 100644 libguile/poll.c
copy libguile/{gdbint.h => poll.h} (79%)
create mode 100644 module/ice-9/poll.scm
diff --git a/configure.ac b/configure.ac
index 631198b..1aa6f05 100644
--- a/configure.ac
+++ b/configure.ac
@@ -644,7 +644,7 @@ AC_CHECK_HEADERS([complex.h fenv.h io.h libc.h limits.h
malloc.h memory.h proces
regex.h rxposix.h rx/rxposix.h sys/dir.h sys/ioctl.h sys/select.h \
sys/time.h sys/timeb.h sys/times.h sys/stdtypes.h sys/types.h \
sys/utime.h time.h unistd.h utime.h pwd.h grp.h sys/utsname.h \
-direct.h langinfo.h nl_types.h machine/fpu.h])
+direct.h langinfo.h nl_types.h machine/fpu.h poll.h])
# Reasons for testing:
# nl_item - lacking on Cygwin
@@ -741,6 +741,7 @@ AC_CHECK_HEADERS([assert.h crt_externs.h])
# gmtime_r - recent posix, not on old systems
# pipe - not in mingw
# _pipe - specific to mingw, taking 3 args
+# poll - since posix 2001
# readdir_r - recent posix, not on old systems
# readdir64_r - not available on HP-UX 11.11
# stat64 - SuS largefile stuff, not on old systems
@@ -753,7 +754,7 @@ AC_CHECK_HEADERS([assert.h crt_externs.h])
# utimensat: posix.1-2008
# sched_getaffinity, sched_setaffinity: GNU extensions (glibc)
#
-AC_CHECK_FUNCS([DINFINITY DQNAN cexp chsize clog clog10 ctermid fesetround
ftime ftruncate fchown getcwd geteuid getsid gettimeofday gmtime_r ioctl lstat
mkdir mknod nice pipe _pipe readdir_r readdir64_r readlink rename rmdir select
setegid seteuid setlocale setpgid setsid sigaction siginterrupt stat64 strftime
strptime symlink sync sysconf tcgetpgrp tcsetpgrp times uname waitpid strdup
system usleep atexit on_exit chown link fcntl ttyname getpwent getgrent kill
getppid getpgrp fork setitimer getitimer strchr strcmp index bcopy memcpy
rindex truncate unsetenv isblank _NSGetEnviron strcoll strcoll_l newlocale
nl_langinfo utimensat sched_getaffinity sched_setaffinity])
+AC_CHECK_FUNCS([DINFINITY DQNAN cexp chsize clog clog10 ctermid fesetround
ftime ftruncate fchown getcwd geteuid getsid gettimeofday gmtime_r ioctl lstat
mkdir mknod nice pipe _pipe poll readdir_r readdir64_r readlink rename rmdir
select setegid seteuid setlocale setpgid setsid sigaction siginterrupt stat64
strftime strptime symlink sync sysconf tcgetpgrp tcsetpgrp times uname waitpid
strdup system usleep atexit on_exit chown link fcntl ttyname getpwent getgrent
kill getppid getpgrp fork setitimer getitimer strchr strcmp index bcopy memcpy
rindex truncate unsetenv isblank _NSGetEnviron strcoll strcoll_l newlocale
nl_langinfo utimensat sched_getaffinity sched_setaffinity])
# Reasons for testing:
# netdb.h - not in mingw
diff --git a/libguile/Makefile.am b/libguile/Makefile.am
index 55a9764..dd797ea 100644
--- a/libguile/Makefile.am
+++ b/libguile/Makefile.am
@@ -170,6 +170,7 @@ address@hidden@_la_SOURCES =
\
objprop.c \
options.c \
pairs.c \
+ poll.c \
ports.c \
print.c \
procprop.c \
@@ -541,6 +542,7 @@ modinclude_HEADERS = \
objprop.h \
options.h \
pairs.h \
+ poll.h \
ports.h \
posix.h \
print.h \
diff --git a/libguile/_scm.h b/libguile/_scm.h
index eb3a8a2..5421116 100644
--- a/libguile/_scm.h
+++ b/libguile/_scm.h
@@ -87,12 +87,24 @@
#include "libguile/inline.h"
#include "libguile/strings.h"
+/* ASYNC_TICK after finding EINTR in order to handle pending signals, if
+ any. See comment in scm_syserror. */
#ifndef SCM_SYSCALL
#ifdef vms
# ifndef __GNUC__
# include <ssdef.h>
-# define SCM_SYSCALL(line) do{errno = 0;line;} \
- while(EVMSERR==errno && (vaxc$errno>>3)==(SS$_CONTROLC>>3))
+# define SCM_SYSCALL(line) \
+ do \
+ { \
+ errno = 0; \
+ line; \
+ if (EVMSERR==errno && (vaxc$errno>>3)==(SS$_CONTROLC>>3)) \
+ { \
+ SCM_ASYNC_TICK; \
+ continue; \
+ } \
+ } \
+ while(0)
# endif /* ndef __GNUC__ */
#endif /* def vms */
#endif /* ndef SCM_SYSCALL */
@@ -100,7 +112,18 @@
#ifndef SCM_SYSCALL
# ifdef EINTR
# if (EINTR > 0)
-# define SCM_SYSCALL(line) do{errno = 0;line;}while(EINTR==errno)
+# define SCM_SYSCALL(line) \
+ do \
+ { \
+ errno = 0; \
+ line; \
+ if (errno == EINTR) \
+ { \
+ SCM_ASYNC_TICK; \
+ continue; \
+ } \
+ } \
+ while(0)
# endif /* (EINTR > 0) */
# endif /* def EINTR */
#endif /* ndef SCM_SYSCALL */
diff --git a/libguile/init.c b/libguile/init.c
index bb916dc..c2b80e0 100644
--- a/libguile/init.c
+++ b/libguile/init.c
@@ -88,6 +88,7 @@
#include "libguile/objprop.h"
#include "libguile/options.h"
#include "libguile/pairs.h"
+#include "libguile/poll.h"
#include "libguile/ports.h"
#include "libguile/posix.h"
#ifdef HAVE_REGCOMP
@@ -459,6 +460,7 @@ scm_i_init_guile (SCM_STACKITEM *base)
scm_register_foreign ();
scm_register_srfi_1 ();
scm_register_srfi_60 ();
+ scm_register_poll ();
scm_init_strings (); /* Requires array-handle */
scm_init_struct (); /* Requires strings */
diff --git a/libguile/poll.c b/libguile/poll.c
new file mode 100644
index 0000000..0304448
--- /dev/null
+++ b/libguile/poll.c
@@ -0,0 +1,146 @@
+/* Copyright (C) 2010 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
+ */
+
+
+
+
+#define _GNU_SOURCE
+
+#ifdef HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+#include "libguile/_scm.h"
+#include "libguile/bytevectors.h"
+#include "libguile/numbers.h"
+#include "libguile/error.h"
+#include "libguile/validate.h"
+
+#include "libguile/poll.h"
+
+
+#ifdef HAVE_POLL_H
+#include <poll.h>
+#endif
+
+
+
+/* {Poll}
+ */
+
+/* Poll a set of file descriptors, waiting until one or more of them is
+ ready to perform input or output.
+
+ This is a low-level interface. See the `(ice-9 poll)' module for a more
+ usable wrapper.
+
+ `pollfds' is expected to be a bytevector, laid out in contiguous blocks of
64
+ bits. Each block has the format of one `struct pollfd': a 32-bit int file
+ descriptor, a 16-bit int events mask, and a 16-bit int revents mask.
+
+ The number of pollfd structures in `pollfds' is specified in
+ `nfds'. `pollfds' must be at least long enough to support that number of
+ structures. It may be longer, in which case the trailing entries are left
+ untouched.
+
+ The pollfds bytevector is modified directly, setting the returned events in
+ the final two bytes (the revents member).
+
+ If timeout is given and is non-negative, the poll will return after that
+ number of milliseconds if no fd became active.
+ */
+#ifdef HAVE_POLL
+static SCM
+scm_primitive_poll (SCM pollfds, SCM nfds, SCM timeout)
+#define FUNC_NAME "primitive-poll"
+{
+ int rv;
+ nfds_t c_nfds;
+ int c_timeout;
+ struct pollfd *fds;
+
+ SCM_VALIDATE_BYTEVECTOR (SCM_ARG1, pollfds);
+ c_nfds = scm_to_uint32 (nfds);
+ c_timeout = scm_to_int (timeout);
+
+ if (SCM_UNLIKELY (SCM_BYTEVECTOR_LENGTH (pollfds)
+ < c_nfds * sizeof(struct pollfd)))
+ SCM_OUT_OF_RANGE (SCM_ARG1, nfds);
+
+ fds = (struct pollfd*)SCM_BYTEVECTOR_CONTENTS (pollfds);
+
+ SCM_SYSCALL (rv = poll (fds, c_nfds, c_timeout));
+
+ if (rv == -1)
+ SCM_SYSERROR;
+
+ return scm_from_int (rv);
+}
+#undef FUNC_NAME
+#endif /* HAVE_POLL */
+
+
+
+
+static void
+scm_init_poll (void)
+{
+#if HAVE_POLL
+ scm_c_define_gsubr ("primitive-poll", 3, 0, 0, scm_primitive_poll);
+#else
+ scm_misc_error ("%init-poll", "`poll' unavailable on this platform",
SCM_EOL);
+#endif
+
+#ifdef POLLIN
+ scm_c_define ("POLLIN", scm_from_int (POLLIN));
+#endif
+#ifdef POLLPRI
+ scm_c_define ("POLLPRI", scm_from_int (POLLPRI));
+#endif
+#ifdef POLLOUT
+ scm_c_define ("POLLOUT", scm_from_int (POLLOUT));
+#endif
+#ifdef POLLRDHUP
+ scm_c_define ("POLLRDHUP", scm_from_int (POLLRDHUP));
+#endif
+#ifdef POLLERR
+ scm_c_define ("POLLERR", scm_from_int (POLLERR));
+#endif
+#ifdef POLLHUP
+ scm_c_define ("POLLHUP", scm_from_int (POLLHUP));
+#endif
+#ifdef POLLNVAL
+ scm_c_define ("POLLNVAL", scm_from_int (POLLNVAL));
+#endif
+
+}
+
+void
+scm_register_poll (void)
+{
+ scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION,
+ "scm_init_poll",
+ (scm_t_extension_init_func) scm_init_poll,
+ NULL);
+}
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
diff --git a/libguile/gdbint.h b/libguile/poll.h
similarity index 79%
copy from libguile/gdbint.h
copy to libguile/poll.h
index d7c6cf3..ab31950 100644
--- a/libguile/gdbint.h
+++ b/libguile/poll.h
@@ -1,9 +1,9 @@
/* classes: h_files */
-#ifndef SCM_GDBINT_H
-#define SCM_GDBINT_H
+#ifndef SCM_POLL_H
+#define SCM_POLL_H
-/* Copyright (C) 1996,2000, 2006, 2008 Free Software Foundation, Inc.
+/* Copyright (C) 2010 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
@@ -27,11 +27,9 @@
-SCM_API int scm_print_carefully_p;
+SCM_INTERNAL void scm_register_poll (void);
-SCM_INTERNAL void scm_init_gdbint (void);
-
-#endif /* SCM_GDBINT_H */
+#endif /* SCM_POLL_H */
/*
Local Variables:
diff --git a/module/Makefile.am b/module/Makefile.am
index e16cd55..67d530a 100644
--- a/module/Makefile.am
+++ b/module/Makefile.am
@@ -200,6 +200,7 @@ ICE_9_SOURCES = \
ice-9/occam-channel.scm \
ice-9/optargs.scm \
ice-9/poe.scm \
+ ice-9/poll.scm \
ice-9/popen.scm \
ice-9/posix.scm \
ice-9/q.scm \
diff --git a/module/ice-9/poll.scm b/module/ice-9/poll.scm
new file mode 100644
index 0000000..e506e2a
--- /dev/null
+++ b/module/ice-9/poll.scm
@@ -0,0 +1,175 @@
+;; poll
+
+;;;; Copyright (C) 2010 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
+;;;;
+
+(define-module (ice-9 poll)
+ #:use-module (srfi srfi-9)
+ #:use-module (srfi srfi-9 gnu)
+ #:use-module (rnrs bytevectors)
+ #:export (make-empty-poll-set
+ poll-set?
+ poll-set-nfds
+ poll-set-find-port
+ poll-set-port
+ poll-set-events
+ set-poll-set-events!
+ poll-set-revents
+ set-poll-set-revents!
+ poll-set-add!
+ poll-set-remove!
+ poll))
+
+(eval-when (eval load compile)
+ (load-extension (string-append "libguile-" (effective-version))
+ "scm_init_poll"))
+
+(if (defined? 'POLLIN)
+ (export POLLIN))
+
+(if (defined? 'POLLPRI)
+ (export POLLPRI))
+
+(if (defined? 'POLLOUT)
+ (export POLLOUT))
+
+(if (defined? 'POLLRDHUP)
+ (export POLLRDHUP))
+
+(if (defined? 'POLLERR)
+ (export POLLERR))
+
+(if (defined? 'POLLHUP)
+ (export POLLHUP))
+
+(if (defined? 'POLLNVAL)
+ (export POLLNVAL))
+
+
+(define-record-type <poll-set>
+ (make-poll-set pollfds nfds ports)
+ poll-set?
+ (pollfds pset-pollfds set-pset-pollfds!)
+ (nfds poll-set-nfds set-pset-nfds!)
+ (ports pset-ports set-pset-ports!)
+ )
+
+(define-syntax pollfd-offset
+ (syntax-rules ()
+ ((_ n) (* n 8))))
+
+(define* (make-empty-poll-set #:optional (pre-allocated 4))
+ (make-poll-set (make-bytevector (pollfd-offset pre-allocated) 0)
+ 0
+ (make-vector pre-allocated #f)))
+
+(define (pset-size set)
+ (vector-length (pset-ports set)))
+
+(define (ensure-pset-size! set size)
+ (let ((prev (pset-size set)))
+ (if (< prev size)
+ (let lp ((new prev))
+ (if (< new size)
+ (lp (* new 2))
+ (let ((old-pollfds (pset-pollfds set))
+ (nfds (poll-set-nfds set))
+ (old-ports (pset-ports set))
+ (new-pollfds (make-bytevector (pollfd-offset new) 0))
+ (new-ports (make-vector new #f)))
+ (bytevector-copy! old-pollfds 0 new-pollfds 0
+ (pollfd-offset nfds))
+ (vector-move-left! old-ports 0 nfds new-ports 0)
+ (set-pset-pollfds! set new-pollfds)
+ (set-pset-ports! set new-ports)))))))
+
+(define (poll-set-find-port set port)
+ (let lp ((i 0))
+ (if (< i (poll-set-nfds set))
+ (if (equal? (vector-ref (pset-ports set) i) port)
+ i
+ (lp (1+ i)))
+ #f)))
+
+(define (poll-set-port set idx)
+ (if (< idx (poll-set-nfds set))
+ (vector-ref (pset-ports set) idx)
+ (error "poll set index out of bounds" set idx)))
+
+(define (poll-set-events set idx)
+ (if (< idx (poll-set-nfds set))
+ (bytevector-u16-native-ref (pset-pollfds set) (+ (pollfd-offset idx) 4))
+ (error "poll set index out of bounds" set idx)))
+
+(define (set-poll-set-events! set idx events)
+ (if (< idx (poll-set-nfds set))
+ (bytevector-u16-native-set! (pset-pollfds set) (+ (pollfd-offset idx) 4)
+ events)
+ (error "poll set index out of bounds" set idx)))
+
+(define (poll-set-revents set idx)
+ (if (< idx (poll-set-nfds set))
+ (bytevector-u16-native-ref (pset-pollfds set) (+ (pollfd-offset idx) 6))
+ (error "poll set index out of bounds" set idx)))
+
+(define (set-poll-set-revents! set idx revents)
+ (if (< idx (poll-set-nfds set))
+ (bytevector-u16-native-set! (pset-pollfds set) (+ (pollfd-offset idx) 6)
+ revents)
+ (error "poll set index out of bounds" set idx)))
+
+(define (poll-set-add! set fd-or-port events)
+ (let* ((idx (poll-set-nfds set))
+ (off (pollfd-offset idx))
+ (fd (if (integer? fd-or-port)
+ fd-or-port
+ (port->fdes fd-or-port))))
+
+ (if (port? fd-or-port)
+ ;; As we store the port in the fdset, there is no need to
+ ;; increment the revealed count to prevent the fd from being
+ ;; closed by a gc'd port.
+ (release-port-handle fd-or-port))
+
+ (ensure-pset-size! set (1+ idx))
+ (bytevector-s32-native-set! (pset-pollfds set) off fd)
+ (bytevector-u16-native-set! (pset-pollfds set) (+ off 4) events)
+ (bytevector-u16-native-set! (pset-pollfds set) (+ off 6) 0) ; revents
+ (vector-set! (pset-ports set) idx fd-or-port)
+ (set-pset-nfds! set (1+ idx))))
+
+(define (poll-set-remove! set idx)
+ (if (not (< idx (poll-set-nfds set)))
+ (error "poll set index out of bounds" set idx))
+ (let ((nfds (poll-set-nfds set))
+ (off (pollfd-offset idx))
+ (port (vector-ref (pset-ports set) idx)))
+ (vector-move-left! (pset-ports set) (1+ idx) nfds
+ (pset-ports set) idx)
+ (vector-set! (pset-ports set) (1- nfds) #f)
+ (bytevector-copy! (pset-pollfds set) (pollfd-offset (1+ idx))
+ (pset-pollfds set) off
+ (- (pollfd-offset nfds) (pollfd-offset (1+ idx))))
+ ;; zero the struct pollfd all at once
+ (bytevector-u64-native-set! (pset-pollfds set) (pollfd-offset (1- nfds)) 0)
+ (set-pset-nfds! set (1- nfds))
+ port))
+
+(define* (poll poll-set #:optional (timeout -1))
+ (primitive-poll (pset-pollfds poll-set)
+ (poll-set-nfds poll-set)
+ timeout))
diff --git a/module/web/server.scm b/module/web/server.scm
index 8fd63c8..3d7c411 100644
--- a/module/web/server.scm
+++ b/module/web/server.scm
@@ -43,19 +43,12 @@
;;; server socket object, or signals an error.
;;;
;;; * The `read' hook is called, to read a request from a new client.
-;;; The `read' hook takes two arguments: the server socket, and a
-;;; list of keep-alive clients. It should return four values: the
-;;; new list of keep-alive clients, an opaque client socket, the
+;;; The `read' hook takes one arguments, the server socket. It
+;;; should return three values: an opaque client socket, the
;;; request, and the request body. The request should be a
;;; `<request>' object, from `(web request)'. The body should be a
;;; string or a bytevector, or `#f' if there is no body.
;;;
-;;; The keep-alive list is used when selecting a new request. You
-;;; can either serve an old client or serve a new client; and some
-;;; old clients might close their connections while you are waiting.
-;;; The `read' hook returns a new keep-alive set to account for old
-;;; clients going away, and for read errors on old clients.
-;;;
;;; If the read failed, the `read' hook may return #f for the client
;;; socket, request, and body.
;;;
@@ -68,14 +61,11 @@
;;; constructed with those headers.
;;;
;;; * The `write' hook is called with three arguments: the client
-;;; socket, the response, and the body. The `write' hook may return
-;;; #f to indicate that the connection was closed. If `write'
-;;; returns a true value, it will be consed onto the keep-alive
-;;; list.
+;;; socket, the response, and the body. The `write' hook returns no
+;;; values.
;;;
;;; * At this point the request handling is complete. For a loop, we
-;;; loop back with the new keep-alive list, and try to read a new
-;;; request.
+;;; loop back and try to read a new request.
;;;
;;; * If the user interrupts the loop, the `close' hook is called on
;;; the server socket.
@@ -149,17 +139,17 @@
(define (open-server impl open-params)
(apply (server-impl-open impl) open-params))
-;; -> (keep-alive client request body | keep-alive #f #f #f)
-(define (read-client impl server keep-alive)
+;; -> (client request body | #f #f #f)
+(define (read-client impl server)
(call-with-error-handling
(lambda ()
- ((server-impl-read impl) server keep-alive))
+ ((server-impl-read impl) server))
#:pass-keys '(quit interrupt)
#:on-error (if (batch-mode?) 'pass 'debug)
#:post-error
(lambda (k . args)
(warn "Error while accepting client" k args)
- (values keep-alive #f #f #f))))
+ (values #f #f #f))))
(define (call-with-encoded-output-string charset proc)
(if (and (string-ci=? charset "utf-8") #f)
@@ -256,7 +246,7 @@
(warn "Error handling request" k args)
(values (build-response #:code 500) #f state))))
-;; -> (#f | client)
+;; -> unspecified values
(define (write-client impl server client response body)
(call-with-error-handling
(lambda ()
@@ -266,7 +256,7 @@
#:post-error
(lambda (k . args)
(warn "Error while writing response" k args)
- #f)))
+ (values))))
;; -> unspecified values
(define (close-server impl server)
@@ -298,16 +288,13 @@
(lambda (k proc)
(with-stack-and-prompt (lambda () (proc k))))))
-(define (and-cons x xs)
- (if x (cons x xs) xs))
-
-;; -> new keep-alive new-state
-(define (serve-one-client handler impl server keep-alive state)
+;; -> new-state
+(define (serve-one-client handler impl server state)
(debug-elapsed 'serve-again)
(call-with-values
(lambda ()
- (read-client impl server keep-alive))
- (lambda (keep-alive client request body)
+ (read-client impl server))
+ (lambda (client request body)
(debug-elapsed 'read-client)
(if client
(call-with-values
@@ -315,13 +302,10 @@
(handle-request handler request body state))
(lambda (response body state)
(debug-elapsed 'handle-request)
- (values
- (and-cons (let ((x (write-client impl server client response
body)))
- (debug-elapsed 'write-client)
- x)
- keep-alive)
- state)))
- (values keep-alive state)))))
+ (write-client impl server client response body)
+ (debug-elapsed 'write-client)
+ state))
+ state))))
(define* (run-server handler #:optional (impl 'http) (open-params '())
. state)
@@ -329,12 +313,8 @@
(server (open-server impl open-params)))
(call-with-sigint
(lambda ()
- (let lp ((keep-alive '()) (state state))
- (call-with-values
- (lambda ()
- (serve-one-client handler impl server keep-alive state))
- (lambda (new-keep-alive new-state)
- (lp new-keep-alive new-state)))))
+ (let lp ((state state))
+ (lp (serve-one-client handler impl server state))))
(lambda ()
(close-server impl server)
(values)))))
diff --git a/module/web/server/http.scm b/module/web/server/http.scm
index 6ec414b..1628e1d 100644
--- a/module/web/server/http.scm
+++ b/module/web/server/http.scm
@@ -21,10 +21,12 @@
(define-module (web server http)
#:use-module ((srfi srfi-1) #:select (fold))
+ #:use-module (srfi srfi-9)
#:use-module (rnrs bytevectors)
#:use-module (web request)
#:use-module (web response)
#:use-module (web server)
+ #:use-module (ice-9 poll)
#:use-module (system repl error-handling))
@@ -34,72 +36,90 @@
(bind sock family addr port)
sock))
+(define-record-type <http-server>
+ (make-http-server socket poll-idx poll-set)
+ http-server?
+ (socket http-socket)
+ (poll-idx http-poll-idx set-http-poll-idx!)
+ (poll-set http-poll-set))
+
+(define *error-events* (logior POLLHUP POLLERR))
+(define *read-events* POLLIN)
+(define *events* (logior *error-events* *read-events*))
+
;; -> server
(define* (http-open #:key
- (host #f)
- (family AF_INET)
- (addr (if host
- (inet-pton family host)
- INADDR_LOOPBACK))
- (port 8080)
- (socket (make-default-socket family addr port)))
+ (host #f)
+ (family AF_INET)
+ (addr (if host
+ (inet-pton family host)
+ INADDR_LOOPBACK))
+ (port 8080)
+ (socket (make-default-socket family addr port)))
(listen socket 5)
(sigaction SIGPIPE SIG_IGN)
- socket)
+ (let ((poll-set (make-empty-poll-set)))
+ (poll-set-add! poll-set socket *events*)
+ (make-http-server socket 1 poll-set)))
-;; -> (keep-alive client request body | keep-alive #f #f #f)
-(define (http-read server keep-alive)
- (call-with-values (lambda ()
- (let ((ports (cons server keep-alive)))
- (apply values (select ports '() ports))))
- (lambda (readable writable except)
+;; -> (client request body | #f #f #f)
+(define (http-read server)
+ (let* ((poll-set (http-poll-set server)))
+ (let lp ((idx (http-poll-idx server)))
(cond
- ((pair? except)
- (values (fold (lambda (p keep-alive)
- (close-port p)
- (if (eq? p server)
- (throw 'interrupt)
- (delq p keep-alive)))
- keep-alive
- except)
- #f #f #f))
- ((memq server readable)
- ;; FIXME: meta to read-request
- (let* ((client (let ((pair (accept server)))
- ;; line buffered for request
- (setvbuf (car pair) _IOLBF)
- pair))
- (req (read-request (car client)))
- (body-str (begin
- ;; block buffered for body and response
- (setvbuf (car client) _IOFBF)
- (read-request-body/latin-1 req))))
- (values keep-alive (car client) req body-str)))
- ((pair? readable)
- ;; FIXME: preserve meta for keep-alive
- (let* ((p (car readable))
- (keep-alive (delq p keep-alive)))
- (if (eof-object? (peek-char p))
- (begin
- (close-port p)
- (values keep-alive #f #f #f))
- (call-with-error-handling
- (lambda ()
- ;; http-write already left p in line-buffered state
- (let* ((req (read-request p))
- (body-str (begin
- ;; block buffered for body and response
- (setvbuf p _IOFBF)
- (read-request-body/latin-1 req))))
- (values keep-alive p req body-str)))
- #:pass-keys '(quit interrupt)
- #:on-error (if (batch-mode?) 'pass 'debug)
- #:post-error
- (lambda (k . args)
- (warn "Error while reading request" k args)
- (values keep-alive #f #f #f #f))))))
+ ((not (< idx (poll-set-nfds poll-set)))
+ (poll poll-set)
+ (lp 0))
(else
- (values keep-alive #f #f #f))))))
+ (let ((revents (poll-set-revents poll-set idx)))
+ (cond
+ ((zero? revents)
+ ;; Nothing on this port.
+ (lp (1+ idx)))
+ ((zero? idx)
+ ;; The server socket.
+ (if (not (zero? (logand revents *error-events*)))
+ ;; An error.
+ (throw 'interrupt)
+ ;; Otherwise, we have a new client. Add to set, then
+ ;; find another client that is ready to read.
+ ;;
+ ;; FIXME: preserve meta-info.
+ (let ((client (accept (poll-set-port poll-set idx))))
+ ;; Set line buffering while reading the request.
+ (setvbuf (car client) _IOLBF)
+ (poll-set-add! poll-set (car client) *events*)
+ (lp (1+ idx)))))
+ ;; Otherwise, a client socket with some activity on
+ ;; it. Remove it from the poll set.
+ (else
+ (let ((port (poll-set-remove! poll-set idx)))
+ (cond
+ ((or (not (zero? (logand revents *error-events*)))
+ (eof-object? (peek-char port)))
+ ;; The socket was shut down or had an error. See
+ ;; http://www.greenend.org.uk/rjk/2001/06/poll.html
+ ;; for an interesting discussion.
+ (close-port port)
+ (lp idx))
+ (else
+ ;; Otherwise, try to read a request from this port.
+ ;; Next time we start with this index.
+ (set-http-poll-idx! server idx)
+ (call-with-error-handling
+ (lambda ()
+ (let ((req (read-request port)))
+ ;; Block buffering for reading body and writing response.
+ (setvbuf port _IOFBF)
+ (values port
+ req
+ (read-request-body/latin-1 req))))
+ #:pass-keys '(quit interrupt)
+ #:on-error (if (batch-mode?) 'pass 'debug)
+ #:post-error
+ (lambda (k . args)
+ (warn "Error while reading request" k args)
+ (values #f #f #f))))))))))))))
(define (keep-alive? response)
(let ((v (response-version response)))
@@ -110,9 +130,10 @@
((0) (memq 'keep-alive (response-connection response)))))
(else #f))))
-;; -> (#f | client)
+;; -> 0 values
(define (http-write server client response body)
- (let ((response (write-response response client)))
+ (let* ((response (write-response response client))
+ (port (response-port response)))
(cond
((not body)) ; pass
((string? body)
@@ -121,20 +142,24 @@
(write-response-body/bytevector response body))
(else
(error "Expected a string or bytevector for body" body)))
- (force-output (response-port response))
- (if (keep-alive? response)
- (let ((p (response-port response)))
- ;; back to line buffered
- (setvbuf p _IOLBF)
- p)
- (begin
- (close-port (response-port response))
- #f))))
+ (cond
+ ((keep-alive? response)
+ (force-output port)
+ ;; back to line buffered
+ (setvbuf port _IOLBF)
+ (poll-set-add! (http-poll-set server) port *events*))
+ (else
+ (close-port port)))
+ (values)))
;; -> unspecified values
(define (http-close server)
- (shutdown server 2)
- (close-port server))
+ (let ((poll-set (http-poll-set server)))
+ (let lp ((n (poll-set-nfds poll-set)))
+ (if (positive? n)
+ (begin
+ (close-port (poll-set-remove! poll-set (1- n)))
+ (lp (1- n)))))))
(define-server-impl http
http-open
hooks/post-receive
--
GNU Guile
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, master, updated. release_1-9-13-121-g462a1a0,
Andy Wingo <=