Continue the request processing in a new thread if a request needs to

be made

3 files changed, 62 insertions, 9 deletions

diff --git a/src/scm/webid-oidc/Makefile.am b/src/scm/webid-oidc/Makefile.am
index bdb3af8..0046ca4 100644
--- a/src/scm/webid-oidc/Makefile.am
+++ b/src/scm/webid-oidc/Makefile.am
@@ -44,7 +44,8 @@ dist_webidoidcmod_DATA += \
   %reldir%/client.scm \
   %reldir%/example-app.scm \
   %reldir%/rdf-index.scm \
-  %reldir%/http-link.scm
+  %reldir%/http-link.scm \
+  %reldir%/offloading.scm
 
 webidoidcgo_DATA += \
   %reldir%/errors.go \
@@ -76,7 +77,8 @@ webidoidcgo_DATA += \
   %reldir%/client.go \
   %reldir%/example-app.go \
   %reldir%/rdf-index.go \
-  %reldir%/http-link.go
+  %reldir%/http-link.go \
+  %reldir%/offloading.go
 
 EXTRA_DIST += %reldir%/ChangeLog
 
diff --git a/src/scm/webid-oidc/offloading.scm b/src/scm/webid-oidc/offloading.scm
new file mode 100644
index 0000000..9620193
--- /dev/null
+++ b/src/scm/webid-oidc/offloading.scm
@@ -0,0 +1,48 @@
+;; webid-oidc, implementation of the Solid specification
+;; Copyright (C) 2021  Vivien Kraus
+
+;; This program is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU Affero General Public License as
+;; published by the Free Software Foundation, either version 3 of the
+;; License, or (at your option) any later version.
+
+;; This program 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 Affero General Public License for more details.
+
+;; You should have received a copy of the GNU Affero General Public License
+;; along with this program.  If not, see <https://www.gnu.org/licenses/>.
+
+(define-module (webid-oidc offloading)
+  #:use-module (ice-9 threads)
+  #:export (with-threads in-another-thread))
+
+(define tag (make-prompt-tag))
+
+(define (let-threads-escape thunk)
+  (call-with-prompt tag
+    (lambda ()
+      (thunk))
+    (lambda (k handle-continuation)
+      (handle-continuation k))))
+
+(define (continue-in-another-thread thunk)
+  (abort-to-prompt
+   tag
+   (lambda (continuation)
+     (call-with-new-thread
+      (lambda ()
+        (let-threads-escape
+         (lambda ()
+           (call-with-values
+               thunk
+             continuation))))))))
+
+(define-syntax-rule (with-threads body ...)
+  (let-threads-escape
+   (lambda () body ...)))
+
+(define-syntax-rule (in-another-thread body ...)
+  (continue-in-another-thread
+   (lambda () body ...)))
diff --git a/src/scm/webid-oidc/program.scm b/src/scm/webid-oidc/program.scm
index 069c5e8..b613717 100644
--- a/src/scm/webid-oidc/program.scm
+++ b/src/scm/webid-oidc/program.scm
@@ -23,6 +23,7 @@
   #:use-module (webid-oidc resource-server)
   #:use-module (webid-oidc server create)
   #:use-module (webid-oidc jti)
+  #:use-module (webid-oidc offloading)
   #:use-module ((webid-oidc stubs) #:prefix stubs:)
   #:use-module ((webid-oidc config) #:prefix cfg:)
   #:use-module (ice-9 optargs)
@@ -57,7 +58,8 @@
     (format (current-error-port) "~a: GET ~a ~s...\n"
             date uri-string headers))
   (receive (response response-body)
-      (http-get uri #:headers headers)
+      (in-another-thread
+       (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
@@ -170,12 +172,13 @@
         (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)))))
+       (with-threads
+        (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