Package: guix-patches;
Reported by: Mathieu Othacehe <othacehe <at> gnu.org>
Date: Fri, 13 Aug 2021 10:29:02 UTC
Severity: normal
Tags: patch
View this message in rfc822 format
From: Mathieu Othacehe <othacehe <at> gnu.org> To: 50040 <at> debbugs.gnu.org Cc: Mathieu Othacehe <othacehe <at> gnu.org> Subject: [bug#50040] [PATCH 1/2] publish: Defer narinfo string creation to the http-write. Date: Fri, 13 Aug 2021 12:30:29 +0200
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.
---
guix/scripts/publish.scm | 82 +++++++++++++++++++++++++++++++++-------
1 file changed, 69 insertions(+), 13 deletions(-)
diff --git a/guix/scripts/publish.scm b/guix/scripts/publish.scm
index 913cbd4fda..981ef8d267 100644
--- a/guix/scripts/publish.scm
+++ b/guix/scripts/publish.scm
@@ -24,6 +24,7 @@
#: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)
@@ -409,15 +410,18 @@ appropriate duration. NAR-PATH specifies the prefix for nar URLs."
(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))
@@ -672,19 +676,38 @@ requested using POOL."
(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))
@@ -839,7 +862,8 @@ example: \"/foo/bar\" yields '(\"foo\" \"bar\")."
"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."
@@ -973,6 +997,38 @@ blocking."
(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)
--
2.32.0
GNU bug tracking system
Copyright (C) 1999 Darren O. Benham,
1997,2003 nCipher Corporation Ltd,
1994-97 Ian Jackson.