Start client requests in a new POSIX thread.

1 files changed, 85 insertions, 48 deletions

diff --git a/src/scm/webid-oidc/program.scm b/src/scm/webid-oidc/program.scm
index be72f75..069c5e8 100644
--- a/src/scm/webid-oidc/program.scm
+++ b/src/scm/webid-oidc/program.scm
@@ -29,8 +29,9 @@
   #:use-module (ice-9 receive)
   #:use-module (ice-9 i18n)
   #:use-module (ice-9 getopt-long)
-  #:use-module (ice-9 suspendable-ports)
   #:use-module (ice-9 control)
+  #:use-module (ice-9 threads)
+  #:use-module (ice-9 futures)
   #:use-module (srfi srfi-19)
   #:use-module (rnrs bytevectors)
   #:use-module (web uri)
@@ -47,24 +48,30 @@
         (car (reverse (string-split text #\|)))
         out)))
 
+(define logging-mutex (make-mutex))
+
 (define* (http-get-with-log uri #:key (headers '()))
   (define date (date->string (time-utc->date (current-time))))
   (define uri-string (if (uri? uri) (uri->string uri) uri))
-  (format (current-error-port) "~a: GET ~a ~s...\n"
-          date uri-string headers)
-  (receive (response response-body) (http-get uri #:headers headers)
-    (format (current-error-port) "~a: GET ~a ~s: ~s ~a bytes\n"
-            date uri-string headers response
-            (cond
-             ((bytevector? response-body)
-              (bytevector-length response-body))
-             ((string? response-body)
-              (string-length response-body))
-             (else 0)))
+  (with-mutex logging-mutex
+    (format (current-error-port) "~a: GET ~a ~s...\n"
+            date uri-string headers))
+  (receive (response response-body)
+      (http-get uri #:headers headers)
+    (with-mutex logging-mutex
+      (format (current-error-port) "~a: GET ~a ~s: ~s ~a bytes\n"
+              date uri-string headers response
+              (cond
+               ((bytevector? response-body)
+                (bytevector-length response-body))
+               ((string? response-body)
+                (string-length response-body))
+               (else 0))))
     (values response response-body)))
 
 (define cache-http-get
-  (with-cache #:http-get http-get-with-log))
+  (with-cache
+   #:http-get http-get-with-log))
 
 (define (request-ip-address request)
   ;; The IP address of the remote end
@@ -84,11 +91,12 @@
      (lambda (return)
        (with-exception-handler
            (lambda (error)
-             (format (current-error-port)
-                     (G_ "~a: ~a: Internal server error: ~a\n")
-                     (date->string (time-utc->date (current-time)))
-                     (request-ip-address request)
-                     (error->str error))
+             (with-mutex logging-mutex
+               (format (current-error-port)
+                       (G_ "~a: ~a: Internal server error: ~a\n")
+                       (date->string (time-utc->date (current-time)))
+                       (request-ip-address request)
+                       (error->str error)))
              (return
               (build-response #:code 500
                               #:reason-phrase "Internal Server Error"
@@ -97,11 +105,12 @@
          (lambda ()
            (with-exception-handler
                (lambda (error)
-                 (format (current-error-port)
-                         (G_ "The client locale ~s can’t be approximated by system locale ~s (because ~a), using C.\n")
-                         ((record-accessor &unknown-client-locale 'web-locale) error)
-                         ((record-accessor &unknown-client-locale 'c-locale) error)
-                         (error->str error)))
+                 (with-mutex logging-mutex
+                   (format (current-error-port)
+                           (G_ "The client locale ~s can’t be approximated by system locale ~s (because ~a), using C.\n")
+                           ((record-accessor &unknown-client-locale 'web-locale) error)
+                           ((record-accessor &unknown-client-locale 'c-locale) error)
+                           (error->str error))))
              (lambda ()
                (receive (response response-body user cause)
                    (call-with-values
@@ -120,26 +129,27 @@
                               ;; That’s an error
                               (current-error-port)
                               (current-output-port)))))
-                   (format logging-port
-                           (G_ "~a: ~s ~a ~s ~a\n")
-                           (if user
-                               (format #f (G_ "~a: ~a (~a)")
-                                       (date->string (time-utc->date (current-time)))
-                                       (uri->string user)
-                                       (request-ip-address request))
-                               (format #f (G_ "~a: ~a")
-                                       (date->string (time-utc->date (current-time)))
-                                       (request-ip-address request)))
-                           (request-method request)
-                           (uri-path (request-uri request))
-                           (response-code response)
-                           (if cause
-                               (string-append
-                                (response-reason-phrase response)
-                                " "
-                                (format #f (G_ "(there was an error: ~a)")
-                                        (error->str cause)))
-                               (response-reason-phrase response))))
+                   (with-mutex logging-mutex
+                     (format logging-port
+                             (G_ "~a: ~s ~a ~s ~a\n")
+                             (if user
+                                 (format #f (G_ "~a: ~a (~a)")
+                                         (date->string (time-utc->date (current-time)))
+                                         (uri->string user)
+                                         (request-ip-address request))
+                                 (format #f (G_ "~a: ~a")
+                                         (date->string (time-utc->date (current-time)))
+                                         (request-ip-address request)))
+                             (request-method request)
+                             (uri-path (request-uri request))
+                             (response-code response)
+                             (if cause
+                                 (string-append
+                                  (response-reason-phrase response)
+                                  " "
+                                  (format #f (G_ "(there was an error: ~a)")
+                                          (error->str cause)))
+                                 (response-reason-phrase response)))))
                  (return
                   (build-response
                    #:version (response-version response)
@@ -153,6 +163,34 @@
              #:unwind? #t
              #:unwind-for-type &unknown-client-locale)))))))
 
+(define (serve-one-client* handler implementation server state)
+  ;; Same as serve-one-client, except it is served in a promise.
+  (call-with-values
+      (lambda ()
+        (read-client implementation server))
+    (lambda (client request body)
+      (future
+       (if client
+           (receive (response body state)
+               (handle-request handler request body state)
+             (write-client implementation server client response body)
+             state)
+           state)))))
+
+(define* (run-server*
+          handler
+          #:optional
+          (implementation 'http)
+          (open-params '())
+          . state)
+  ;; Same as the traditional run-server, but the requests are handled
+  ;; in a future and the state is discarded.
+  (let* ((implementation (lookup-server-impl implementation))
+         (server (open-server implementation open-params)))
+    (let lp ()
+      (serve-one-client* handler implementation server state)
+      (lp))))
+
 (define-public (main)
   (setvbuf (current-output-port) 'none)
   (setvbuf (current-error-port) 'none)
@@ -528,7 +566,6 @@ If you find a bug, then please send a report to ~a.
                     (car (command-line))
                     help-sym)
             (exit 1))
-          (install-suspendable-ports!)
           (let ((command (car rest))
                 (non-options (cdr rest)))
             (cond
@@ -542,7 +579,7 @@ If you find a bug, then please send a report to ~a.
                   (format (current-error-port) (G_ "You must pass --~a to set the backend URI.\n")
                           backend-uri-sym)
                   (exit 1))
-                (run-server
+                (run-server*
                  (handler-with-log
                   (option-ref options log-file-sym #f)
                   (option-ref options error-file-sym #f)
@@ -591,7 +628,7 @@ If you find a bug, then please send a report to ~a.
                         (make-jti-list)
                         #:current-time current-time
                         #:http-get cache-http-get)))
-                  (run-server
+                  (run-server*
                    (handler-with-log
                     (option-ref options log-file-sym #f)
                     (option-ref options error-file-sym #f)
@@ -620,7 +657,7 @@ If you find a bug, then please send a report to ~a.
                        (serve-application client-id redirect-uri
                                           #:client-name client-name
                                           #:client-uri client-uri)))
-                  (run-server
+                  (run-server*
                    (handler-with-log
                     (option-ref options log-file-sym #f)
                     (option-ref options error-file-sym #f)
@@ -684,7 +721,7 @@ If you find a bug, then please send a report to ~a.
                         #:current-time current-time
                         #:http-get cache-http-get)))
                   (create-root server-name subject)
-                  (run-server
+                  (run-server*
                    (handler-with-log
                     (option-ref options log-file-sym #f)
                     (option-ref options error-file-sym #f)