From 7f23fb00882dd65b4cad51a9cf52d5f86b32fdb4 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 19 Jul 2015 23:58:37 +0200 Subject: 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. --- guix/scripts/publish.scm | 33 ++++++++++++++++++++++++++++++++- 1 file changed, 32 insertions(+), 1 deletion(-) 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 +;;; Copyright © 2015 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -227,6 +228,36 @@ (define (request-path-components request) 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 @@ (define (make-request-handler store) (define (run-publish-server socket store) (run-server (make-request-handler store) - 'http + concurrent-http-server `(#:socket ,socket))) (define (open-server-socket address) -- cgit v1.2.3