publish: Defer narinfo string creation to the http-write.

The "narinfo-string" procedure is expensive in term of IO operations and can
take a while under IO pressure, such a GC collecting. Defer its call to a new
thread created in the http-write procedure.

Fixes: <https://issues.guix.gnu.org/48468>
Partially fixes: <https://issues.guix.gnu.org/49089>

* guix/scripts/publish.scm (render-narinfo): Defer the narinfo string creation
to the http-write procedure.
(compression->sexp, sexp->compression): New procedures.
("X-Nar-Compression"): Use them.
("X-Narinfo-Compressions"): New custom header.
(strip-headers): Add the x-nar-path header.
(http-write): Add narinfo on-the-fly creation support. It happens in a
separated thread to prevent blocking the main thread.
This commit is contained in:
Mathieu Othacehe 2021-08-13 12:30:29 +02:00
parent a7028d4323
commit f743f2046b
No known key found for this signature in database
GPG key ID: 8354763531769CA6

View file

@ -25,6 +25,7 @@ (define-module (guix scripts publish)
#:use-module ((system repl server) #:prefix repl:)
#:use-module (ice-9 binary-ports)
#:use-module (ice-9 format)
#:use-module (ice-9 iconv)
#:use-module (ice-9 match)
#:use-module (ice-9 poll)
#:use-module (ice-9 regex)
@ -400,15 +401,18 @@ (define* (render-narinfo store request hash
(let ((store-path (hash-part->path store hash)))
(if (string-null? store-path)
(not-found request #:phrase "" #:ttl negative-ttl)
(values `((content-type . (application/x-nix-narinfo))
(values `((content-type . (application/x-nix-narinfo
(charset . "UTF-8")))
(x-nar-path . ,nar-path)
(x-narinfo-compressions . ,compressions)
,@(if ttl
`((cache-control (max-age . ,ttl)))
'()))
(cut display
(narinfo-string store store-path
#:nar-path nar-path
#:compressions compressions)
<>)))))
;; Do not call narinfo-string directly here as it is an
;; expensive call that could potentially block the main
;; thread. Instead, create the narinfo string in the
;; http-write procedure.
store-path))))
(define* (nar-cache-file directory item
#:key (compression %no-compression))
@ -663,19 +667,38 @@ (define (compressed-nar-size compression)
(link narinfo other)))
others))))))
(define (compression->sexp compression)
"Return the SEXP representation of COMPRESSION."
(match compression
(($ <compression> type level)
`(compression ,type ,level))))
(define (sexp->compression sexp)
"Turn the given SEXP into a <compression> record and return it."
(match sexp
(('compression type level)
(compression type level))))
;; XXX: Declare the 'X-Nar-Compression' HTTP header, which is in fact for
;; internal consumption: it allows us to pass the compression info to
;; 'http-write', as part of the workaround to <http://bugs.gnu.org/21093>.
(declare-header! "X-Nar-Compression"
(lambda (str)
(match (call-with-input-string str read)
(('compression type level)
(compression type level))))
(sexp->compression
(call-with-input-string str read)))
compression?
(lambda (compression port)
(match compression
(($ <compression> type level)
(write `(compression ,type ,level) port)))))
(write (compression->sexp compression) port)))
;; This header is used to pass the supported compressions to http-write in
;; order to format on-the-fly narinfo responses.
(declare-header! "X-Narinfo-Compressions"
(lambda (str)
(map sexp->compression
(call-with-input-string str read)))
(cut every compression? <>)
(lambda (compressions port)
(write (map compression->sexp compressions) port)))
(define* (render-nar store request store-item
#:key (compression %no-compression))
@ -830,7 +853,8 @@ (define (strip-headers response)
"Return RESPONSE's headers minus 'Content-Length' and our internal headers."
(fold alist-delete
(response-headers response)
'(content-length x-raw-file x-nar-compression)))
'(content-length x-raw-file x-nar-compression
x-narinfo-compressions x-nar-path)))
(define (sans-content-length response)
"Return RESPONSE without its 'content-length' header."
@ -964,6 +988,38 @@ (define compression
(unless keep-alive?
(close-port client)))
(values))))))
(('application/x-nix-narinfo . _)
(let ((compressions (assoc-ref (response-headers response)
'x-narinfo-compressions))
(nar-path (assoc-ref (response-headers response)
'x-nar-path)))
(if nar-path
(begin
(when (keep-alive? response)
(keep-alive client))
(call-with-new-thread
(lambda ()
(set-thread-name "publish narinfo")
(let* ((narinfo
(with-store store
(narinfo-string store (utf8->string body)
#:nar-path nar-path
#:compressions compressions)))
(narinfo-bv (string->bytevector narinfo "UTF-8"))
(narinfo-length
(bytevector-length narinfo-bv))
(response (write-response
(with-content-length response
narinfo-length)
client))
(output (response-port response)))
(configure-socket client)
(put-bytevector output narinfo-bv)
(force-output output)
(unless (keep-alive? response)
(close-port output))
(values)))))
(%http-write server client response body))))
(_
(match (assoc-ref (response-headers response) 'x-raw-file)
((? string? file)