publish: Serve /nar requests in a separate thread.

* guix/scripts/publish.scm (%http-write): New variable.
  (http-write): New procedure.
  (concurrent-http-server): New variable.
  (run-publish-server): Use it.

1 files changed, 32 insertions, 1 deletions

diff --git a/guix/scripts/publish.scm b/guix/scripts/publish.scm
index e0226f35ee..fd1f9f8b4e 100644
--- a/guix/scripts/publish.scm
+++ b/guix/scripts/publish.scm
@@ -1,5 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2015 David Thompson <davet@gnu.org>
+;;; Copyright © 2015 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -227,6 +228,36 @@ is invalid."
 example: \"/foo/bar\" yields '(\"foo\" \"bar\")."
   (split-and-decode-uri-path (uri-path (request-uri request))))
 
+
+;;;
+;;; Server.
+;;;
+
+(define %http-write
+  (@@ (web server http) http-write))
+
+(define (http-write server client response body)
+  "Write RESPONSE and BODY to CLIENT, possibly in a separate thread to avoid
+blocking."
+  (match (response-content-type response)
+    (('application/x-nix-archive . _)
+     ;; Sending the the whole archive can take time so do it in a separate
+     ;; thread so that the main thread can keep working in the meantime.
+     (call-with-new-thread
+      (lambda ()
+        (%http-write server client response body))))
+    (_
+     ;; Handle other responses sequentially.
+     (%http-write server client response body))))
+
+(define-server-impl concurrent-http-server
+  ;; A variant of Guile's built-in HTTP server that offloads possibly long
+  ;; responses to a different thread.
+  (@@ (web server http) http-open)
+  (@@ (web server http) http-read)
+  http-write
+  (@@ (web server http) http-close))
+
 (define (make-request-handler store)
   (lambda (request body)
     (format #t "~a ~a~%"
@@ -248,7 +279,7 @@ example: \"/foo/bar\" yields '(\"foo\" \"bar\")."
 
 (define (run-publish-server socket store)
   (run-server (make-request-handler store)
-              'http
+              concurrent-http-server
               `(#:socket ,socket)))
 
 (define (open-server-socket address)