web: server: Ignore all client disconnects.

EPIPE and ECONNRESET errors are already ignored when thrown by "sendfile" and
"put-bytevector" procedures. It turns out "peek-char" can also cause such
errors. So ignore such errors within the whole procedure.

* src/web/server/fiberized.scm (client-loop): Wrap the whole procedure inside
"with-ignored-disconnects" instead of wrapping individually "sendfile" and
"put-bytevector" calls.

1 files changed, 57 insertions, 56 deletions

diff --git a/src/web/server/fiberized.scm b/src/web/server/fiberized.scm
index 654636b..5df1d58 100644
--- a/src/web/server/fiberized.scm
+++ b/src/web/server/fiberized.scm
@@ -126,62 +126,63 @@ disconnection. Re-raise any other kind of exceptions."
   ;; 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)
-                (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)
-                              (with-ignored-disconnects
-                               (sendfile output input size))
-                              (dump-port input output))
-                          (close-port output)
-                          (values))))))
-                  (#f (begin
-                        (write-response response client)
-                        (when body
-                          (with-ignored-disconnects
-                           (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))))))
+  (with-ignored-disconnects
+   (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)
+                 (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 (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)