[Guile-commits] GNU Guile branch, wip-ethreads, updated. v2.0.5-106-g5061caf

[Andy Wingo]

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=5061caf5dd259e373338eee6bbec3e5f913cf6a3

The branch, wip-ethreads has been updated
       via  5061caf5dd259e373338eee6bbec3e5f913cf6a3 (commit)
       via  cfb082965c9e31aaa5ed4cdbde3a795e60b4e427 (commit)
       via  decf94c4a024d98d0e757bd918f273188742b98b (commit)
       via  e93e30ddd73b641ae2b28cd5c7696ed4421fbae3 (commit)
       via  99368b9b5d9091f04eea1c631bf306c1d7968a7f (commit)
       via  e2daf9387cd3610b955c8805ac74b0c37e9b4958 (commit)
      from  2479c1684e16142c7da8e93dc3a3f3275314e542 (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 5061caf5dd259e373338eee6bbec3e5f913cf6a3
Author: Andy Wingo <address@hidden>
Date:   Mon Mar 26 00:30:07 2012 +0200

    (web server ethreads): Use a large backlog.
    
    * module/web/server/ethreads.scm (open-server): Use a large backlog by
      default.
      (client-loop): Disable Nagle's algorithm, as we handle buffering
      properly.

commit cfb082965c9e31aaa5ed4cdbde3a795e60b4e427
Author: Andy Wingo <address@hidden>
Date:   Mon Mar 26 00:25:03 2012 +0200

    socket: TCP_CORK, TCP_NODELAY
    
    * libguile/socket.c (scm_init_socket): Define TCP_NODELAY and TCP_CORK
      if they are available.

commit decf94c4a024d98d0e757bd918f273188742b98b
Author: Andy Wingo <address@hidden>
Date:   Sun Mar 25 22:21:48 2012 +0200

    EOF fix for continuation-line?
    
    * module/web/server/ethreads.scm (continuation-line?): Fix for EOF.

commit e93e30ddd73b641ae2b28cd5c7696ed4421fbae3
Author: Andy Wingo <address@hidden>
Date:   Fri Mar 23 18:15:49 2012 +0100

    peval supports char->integer and integer->char
    
    * module/language/tree-il/primitives.scm (*interesting-primitive-names*):
      (*effect-free-primitives*, *singly-valued-primitives*): Fold
      char->integer and integer->char.

commit 99368b9b5d9091f04eea1c631bf306c1d7968a7f
Author: Andy Wingo <address@hidden>
Date:   Fri Mar 23 17:43:30 2012 +0100

    eports: some more exports
    
    * module/ice-9/eports.scm: Export putback-u8 and putback-bytevector.

commit e2daf9387cd3610b955c8805ac74b0c37e9b4958
Author: Andy Wingo <address@hidden>
Date:   Fri Mar 23 17:40:12 2012 +0100

    add #:limit to get-bytevector-delimited
    
    * module/ice-9/eports.scm (get-bytevector-delimited): Allow a limit to
      be placed on the size of the bytevector.

-----------------------------------------------------------------------

Summary of changes:
 libguile/socket.c                      |   11 ++++++++-
 module/ice-9/eports.scm                |   32 +++++++++++++++++++--------
 module/language/tree-il/primitives.scm |    4 ++-
 module/web/server/ethreads.scm         |   37 +++++++++++++++++++++++--------
 4 files changed, 62 insertions(+), 22 deletions(-)

diff --git a/libguile/socket.c b/libguile/socket.c
index bfd873d..66ba576 100644
--- a/libguile/socket.c
+++ b/libguile/socket.c
@@ -1,5 +1,5 @@
 /* Copyright (C) 1996, 1997, 1998, 2000, 2001, 2002, 2003, 2004, 2005,
- *   2006, 2007, 2009, 2011 Free Software Foundation, Inc.
+ *   2006, 2007, 2009, 2011, 2012 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
@@ -66,6 +66,7 @@
 #include <sys/un.h>
 #endif
 #include <netinet/in.h>
+#include <netinet/tcp.h>
 #include <netdb.h>
 #include <arpa/inet.h>
 #endif
@@ -1875,6 +1876,14 @@ scm_init_socket ()
   scm_c_define ("MSG_DONTROUTE", scm_from_int (MSG_DONTROUTE));
 #endif
 
+  /* TCP options.  */
+#ifdef TCP_NODELAY
+  scm_c_define ("TCP_NODELAY", scm_from_int (TCP_NODELAY));
+#endif
+#ifdef TCP_CORK
+  scm_c_define ("TCP_CORK", scm_from_int (TCP_CORK));
+#endif
+
 #ifdef __MINGW32__
   scm_i_init_socket_Win32 ();
 #endif
diff --git a/module/ice-9/eports.scm b/module/ice-9/eports.scm
index 18d2291..c0280a3 100644
--- a/module/ice-9/eports.scm
+++ b/module/ice-9/eports.scm
@@ -36,8 +36,10 @@
             accept-eport
 
             get-u8
+            putback-u8
             lookahead-u8
             get-bytevector-some
+            putback-bytevector
             get-bytevector-n
             get-bytevector-n!
             get-bytevector-delimited
@@ -315,7 +317,7 @@
 ;; delimiter, and the delimiter, or the EOF object if EOF was
 ;; encountered first.
 ;;
-(define* (get-bytevector-delimited eport predicate)
+(define* (get-bytevector-delimited eport predicate #:key limit)
   (define (collect-result prev prev-len bv)
     (if (null? prev-len)
         bv
@@ -328,6 +330,15 @@
               (let ((len (bytevector-length (car prev))))
                 (bytevector-copy! (car prev) 0 out (- prev-len len) len)
                 (lp (cdr prev) (- prev-len len)))))))))
+  (define (found-delimiter buf start len delimiter prev prev-len)
+    (when (and limit (> (+ len prev-len) limit))
+      (error "Input too long" limit (+ len prev-len)))
+    (let ((ret (make-bytevector len)))
+      (bytevector-copy! (buf-bv buf) start ret 0 len)
+      ;; Plus one for the delimiter, if present
+      (flush-buffer buf (if (eof-object? delimiter) len (1+ len)))
+      (values (collect-result prev prev-len ret)
+              delimiter)))
   (let ((buf (eport-readbuf eport)))
     (unless buf
       (error "not a readable port" eport))
@@ -335,25 +346,26 @@
            (size (bytevector-length bv)))
       (let lp ((prev '()) (prev-len 0))
         (when (= (buf-cur buf) (buf-end buf))
+          (when (and limit (> prev-len limit))
+            (error "Input too long" limit prev-len))
           (fill-input eport))
         (let ((cur (buf-cur buf))
               (end (buf-end buf)))
           (let search ((i cur))
             (if (< i end)
                 (if (predicate (bytevector-u8-ref bv i))
-                    (let ((ret (make-bytevector (- i cur))))
-                      (bytevector-copy! bv cur ret 0 (- i cur))
-                      ;; Plus one for the delimiter
-                      (flush-buffer buf (1+ (- i cur)))
-                      (values ret (bytevector-u8-ref bv i)))
+                    (found-delimiter buf cur (- i cur)
+                                     (bytevector-u8-ref bv i)
+                                     prev prev-len)
                     (search (1+ i)))
                 (let ((len (- end cur)))
                   (if (zero? len)
                       ;; EOF
-                      (values (if (zero? prev-len)
-                                  the-eof-object
-                                  (collect-result prev prev-len #vu8()))
-                              the-eof-object)
+                      (if (zero? prev-len)
+                          (values the-eof-object
+                                  the-eof-object)
+                          (found-delimiter buf cur len the-eof-object
+                                           prev prev-len))
                       (let ((ret (make-bytevector len)))
                         (bytevector-copy! bv cur ret 0 len)
                         (flush-buffer buf len)
diff --git a/module/language/tree-il/primitives.scm 
b/module/language/tree-il/primitives.scm
index c825d9a..72d5ac8 100644
--- a/module/language/tree-il/primitives.scm
+++ b/module/language/tree-il/primitives.scm
@@ -47,6 +47,7 @@
     not
     pair? null? list? symbol? vector? string? struct?
     acons cons cons*
+    char->integer integer->char
 
     list vector
 
@@ -141,7 +142,7 @@
     + * - / 1- 1+ quotient remainder modulo
     not
     pair? null? list? symbol? vector? struct? string?
-    string-length
+    string-length char->integer integer->char
     ;; These all should get expanded out by expand-primitives!.
     caar cadr cdar cddr
     caaar caadr cadar caddr cdaar cdadr cddar cdddr
@@ -168,6 +169,7 @@
     ash logand logior logxor
     not
     pair? null? list? symbol? vector? acons cons cons*
+    char->integer integer->char
     list vector
     car cdr
     set-car! set-cdr!
diff --git a/module/web/server/ethreads.scm b/module/web/server/ethreads.scm
index 77706bd..17ae37c 100644
--- a/module/web/server/ethreads.scm
+++ b/module/web/server/ethreads.scm
@@ -22,10 +22,6 @@
 ;;; This is the non-blocking HTTP implementation of the (web server)
 ;;; interface.
 ;;;
-;;; `read-request' sets the character encoding on the new port to
-;;; latin-1.  See the note in request.scm regarding character sets,
-;;; strings, and bytevectors for more information.
-;;;
 ;;; Code:
 
 (define-module (web server ethreads)
@@ -63,7 +59,11 @@
                                 INADDR_LOOPBACK))
                       (port 8080)
                       (socket (make-default-socket family addr port)))
-  (listen socket 128)
+  ;; 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)
   (sigaction SIGPIPE SIG_IGN)
   (let* ((ctx (make-econtext))
          (esocket (file-port->eport socket))
@@ -91,9 +91,9 @@
         (utf8->string bv))))))
 
 (define (continuation-line? port)
-  (case (integer->char (lookahead-u8 port))
-    ((#\space #\tab) #t)
-    (else #f)))
+  (let ((c (lookahead-u8 port)))
+    (or (eqv? c (char->integer #\space))
+        (eqv? c (char->integer #\tab)))))
 
 ;; Read a request from this port.
 (define (read-request client)
@@ -134,6 +134,21 @@
               ((0) (memq 'keep-alive (response-connection response)))))
            (else #f)))))
 
+(define cork!
+  (cond
+   ((defined? 'TCP_NODELAY)
+    (lambda (fd cork?)
+      ;; Always disable Nagle's algorithm, as we handle buffering
+      ;; ourselves.  Don't bother disabling if cork? is #f.
+      (when cork?
+        (setsockopt fd IPPROTO_TCP TCP_NODELAY 0))))
+   ((defined? 'TCP_CORK)
+    ;; If we don't have TCP_NODELAY, the Linux-specific TCP_CORK will
+    ;; do.
+    (lambda (fd cork?)
+      (setsockopt fd IPPROTO_TCP TCP_CORK (if cork? 1 0))))
+   (else (lambda (fd cork?) #t))))
+
 (define (client-loop client have-request)
   (with-throw-handler #t
     (lambda ()
@@ -154,6 +169,7 @@
                                           #:headers '((content-length . 0)))
                           #vu8()))))
           (lambda (response body)
+            (cork! (eport-fd client) #t)
             (put-bytevector client
                             (call-with-output-bytevector
                              (lambda (port) (write-response response port))))
@@ -161,7 +177,9 @@
               (put-bytevector client body))
             (drain-output client)
             (if (and (keep-alive? response)
-                     (not (eof-object? (lookahead-u8 client))))
+                     (begin
+                       (cork! (eport-fd client) #f)
+                       (not (eof-object? (lookahead-u8 client)))))
                 (loop)
                 (close-eport client))))))
     (lambda (k . args)
@@ -177,7 +195,6 @@
                      client-thread request body))
   (let loop ()
     (let ((client (accept-eport esocket)))
-      ;; From "HOP, A Fast Server for the Diffuse Web", Serrano.
       (setsockopt (eport-fd client) SOL_SOCKET SO_SNDBUF (* 12 1024))
       (spawn (lambda () (client-loop client have-request)))
       (loop))))


hooks/post-receive
-- 
GNU Guile