[gnunet-scheme] 47/49: web: Extract HTTP implementation from Cuirass.

[gnunet]

This is an automated email from the git hooks/post-receive script.

maxime-devos pushed a commit to branch master
in repository gnunet-scheme.

commit 75d57817db8cb4fa9283d8e56f49ef640fdc4676
Author: Maxime Devos <maximedevos@telenet.be>
AuthorDate: Sat Dec 25 21:18:52 2021 +0000

    web: Extract HTTP implementation from Cuirass.
    
    This should have been commited some time ago.
    
    * web/server/fiberized.scm: New file.
---
 web/server/fiberized.scm | 216 +++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 216 insertions(+)

diff --git a/web/server/fiberized.scm b/web/server/fiberized.scm
new file mode 100644
index 0000000..e44dcaa
--- /dev/null
+++ b/web/server/fiberized.scm
@@ -0,0 +1,216 @@
+;;; 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.)
+;;;
+;;; More commentary: Cuirass code has been removed
+;;;
+;;;
+;;; Code:
+
+
+(define-module (web server fiberized)
+  #:use-module ((srfi srfi-1) #:select (fold
+                                        alist-delete
+                                        alist-cons))
+  #:use-module (srfi srfi-9)
+  #:use-module (srfi srfi-9 gnu)
+  #: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)))))
+
+;; This procedure and the next one are copied from (guix scripts publish).
+(define (strip-headers response)
+  "Return RESPONSE's headers minus 'Content-Length' and our internal headers."
+  (fold alist-delete
+        (response-headers response)
+        '(content-length x-raw-file x-nar-compression)))
+
+(define (with-content-length response length)
+  "Return RESPONSE with a 'content-length' header set to LENGTH."
+  (set-field response (response-headers)
+             (alist-cons 'content-length length
+                         (strip-headers response))))
+
+(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)
+  (catch #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)
+                (match (assoc-ref (response-headers response) 'x-raw-file)
+                  ((? string? file)
+                   (non-blocking
+                    (call-with-input-file file
+                      (lambda (input)
+                        (let* ((size     (stat:size (stat input)))
+                               (response (write-response
+                                          (with-content-length response size)
+                                          client))
+                               (output   (response-port response)))
+                          (setsockopt client SOL_SOCKET SO_SNDBUF
+                                      (* 128 1024))
+                          (if (file-port? output)
+                              (sendfile output input size)
+                              (dump-port input output))
+                          (close-port output)
+                          (values))))))
+                  (#f (begin
+                        (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 args
+      ;; Ignore premature client disconnections.
+      (unless (memv (system-error-errno args)
+                    (list EPIPE ECONNRESET))
+        (apply throw args)))
+    (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)

-- 
To stop receiving notification emails like this one, please contact
gnunet@gnunet.org.