From 2e8df3574c4f7b3cde2b77aa096f13ef2bdbfe3d Mon Sep 17 00:00:00 2001 From: Vivien Kraus Date: Wed, 7 Jul 2021 09:24:36 +0200 Subject: Start client requests in a new POSIX thread. --- src/scm/webid-oidc/program.scm | 133 ++++++++++++++++++++++++++--------------- 1 file changed, 85 insertions(+), 48 deletions(-) (limited to 'src') 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) -- cgit v1.2.3