[Guile-commits] 07/23: add (web server ethreads)

[Andy Wingo]

wingo pushed a commit to branch wip-ethreads
in repository guile.

commit 1b397a35984c9a42accab8680a72fdeb719c8f66
Author: Andy Wingo <address@hidden>
Date:   Sun Mar 18 10:41:18 2012 +0100

    add (web server ethreads)
    
    * module/web/server/ethreads.scm: New file, an ethreads-based HTTP
      server.
    
    * module/Makefile.am: Add to build.
---
 module/Makefile.am             |    1 +
 module/web/server/ethreads.scm |  209 ++++++++++++++++++++++++++++++++++++++++
 2 files changed, 210 insertions(+), 0 deletions(-)

diff --git a/module/Makefile.am b/module/Makefile.am
index edeaeaf..118e41a 100644
--- a/module/Makefile.am
+++ b/module/Makefile.am
@@ -360,6 +360,7 @@ SOURCES =                                   \
   web/response.scm                             \
   web/server.scm                               \
   web/server/http.scm                          \
+  web/server/ethreads.scm                      \
   web/uri.scm
 
 ELISP_SOURCES =                                        \
diff --git a/module/web/server/ethreads.scm b/module/web/server/ethreads.scm
new file mode 100644
index 0000000..77706bd
--- /dev/null
+++ b/module/web/server/ethreads.scm
@@ -0,0 +1,209 @@
+;;; Web I/O: Non-blocking HTTP
+
+;; Copyright (C) 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 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.
+;;;
+;;; `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)
+  #:use-module ((srfi srfi-1) #:select (fold))
+  #:use-module (srfi srfi-9)
+  #:use-module (rnrs bytevectors)
+  #:use-module ((web request) #:hide (read-request read-request-body))
+  #:use-module ((ice-9 binary-ports) #:select (open-bytevector-output-port))
+  #:use-module (web http)
+  #:use-module (web response)
+  #:use-module (web server)
+  #:use-module (ice-9 eports)
+  #:use-module (ice-9 ethreads))
+
+
+(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)
+    sock))
+
+(define-record-type <server>
+  (make-server econtext have-request-prompt)
+  server?
+  (econtext server-econtext)
+  (have-request-prompt server-have-request-prompt))
+
+;; -> 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)))
+  (listen socket 128)
+  (sigaction SIGPIPE SIG_IGN)
+  (let* ((ctx (make-econtext))
+         (esocket (file-port->eport socket))
+         (server (make-server ctx (make-prompt-tag "have-request"))))
+    (spawn (lambda () (socket-loop server esocket)) ctx)
+    server))
+
+(define (bad-request msg . args)
+  (throw 'bad-request msg args))
+
+(define (read-http-line eport)
+  ;; 10 and 13 are #\newline and #\return, respectively.
+  (define (end-of-line? u8)
+    (or (eqv? u8 10) (eqv? u8 13)))
+  (call-with-values (lambda ()
+                      (get-bytevector-delimited eport end-of-line?))
+    (lambda (bv delim)
+      (cond
+       ((eof-object? delim)
+        (bad-request "EOF while reading line: ~S" bv))
+       (else
+        (when (and (eqv? delim 13)
+                   (eqv? (lookahead-u8 eport) 10))
+          (get-u8 eport))
+        (utf8->string bv))))))
+
+(define (continuation-line? port)
+  (case (integer->char (lookahead-u8 port))
+    ((#\space #\tab) #t)
+    (else #f)))
+
+;; Read a request from this port.
+(define (read-request client)
+  (call-with-values (lambda () (read-request-line client read-http-line))
+    (lambda (method uri version)
+      (build-request uri #:method method #:version version
+                     #:headers (read-headers client
+                                             read-http-line
+                                             continuation-line?)
+                     #:port client
+                     #:validate-headers? #f))))
+
+(define (read-request-body r)
+  (let ((nbytes (request-content-length r)))
+    (and nbytes
+         (let ((bv (get-bytevector-n (request-port r) nbytes)))
+           (if (= (bytevector-length bv) nbytes)
+               bv
+               (bad-request "EOF while reading request body: ~a bytes of ~a"
+                            (bytevector-length bv) nbytes))))))
+
+(define (call-with-output-bytevector proc)
+  (call-with-values (lambda () (open-bytevector-output-port))
+    (lambda (port get-bytevector)
+      (proc port)
+      (let ((bv (get-bytevector)))
+        (close-port port)
+        bv))))
+
+(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)
+  (with-throw-handler #t
+    (lambda ()
+      (let loop ()
+        (call-with-values
+            (lambda ()
+              (catch #t
+                (lambda ()
+                  (let* ((request (read-request client))
+                         (body (read-request-body request)))
+                    (suspend
+                     (lambda (ctx thread)
+                       (have-request thread 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)
+            (put-bytevector client
+                            (call-with-output-bytevector
+                             (lambda (port) (write-response response port))))
+            (when body
+              (put-bytevector client body))
+            (drain-output client)
+            (if (and (keep-alive? response)
+                     (not (eof-object? (lookahead-u8 client))))
+                (loop)
+                (close-eport client))))))
+    (lambda (k . args)
+      (catch #t
+        (lambda () (close-eport client #:drain-output? #f))
+        (lambda (k . args)
+          (display "While closing eport:\n" (current-error-port))
+          (print-exception (current-error-port) #f k args))))))
+
+(define (socket-loop server esocket)
+  (define (have-request client-thread request body)
+    (abort-to-prompt (server-have-request-prompt server)
+                     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))))
+
+;; -> (client request body | #f #f #f)
+(define (server-read server)
+  (call-with-prompt
+   (server-have-request-prompt server)
+   (lambda ()
+     (run (server-econtext server)))
+   (lambda (k client request body)
+     (values client request body))))
+
+;; -> 0 values
+(define (server-write server client response body)
+  (when (and body (not (bytevector? body)))
+    (error "Expected a bytevector for body" body))
+  (resume client (lambda () (values response body)) (server-econtext server))
+  (values))
+
+;; -> unspecified values
+(define (close-server server)
+  (destroy-econtext (server-econtext server)))
+
+(define-server-impl ethreads
+  open-server
+  server-read
+  server-write
+  close-server)