summaryrefslogtreecommitdiff
path: root/guix/scripts/publish.scm
diff options
context:
space:
mode:
authorMathieu Othacehe <othacehe@gnu.org>2021-08-13 12:30:29 +0200
committerMathieu Othacehe <othacehe@gnu.org>2021-10-05 18:55:55 +0000
commitf743f2046be2c5a338ab871ae8666d8f6de7440b (patch)
tree464dd1c774bf3f8f7b8cfb66fe72602b8df4725d /guix/scripts/publish.scm
parenta7028d4323744152aaccf66af25ad2c9445bc01e (diff)
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.
Diffstat (limited to 'guix/scripts/publish.scm')
-rw-r--r--guix/scripts/publish.scm82
1 files changed, 69 insertions, 13 deletions
diff --git a/guix/scripts/publish.scm b/guix/scripts/publish.scm
index 25846b7dc2..6e2b4368da 100644
--- a/guix/scripts/publish.scm
+++ b/guix/scripts/publish.scm
@@ -25,6 +25,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)
@@ -400,15 +401,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))
@@ -663,19 +667,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))
@@ -830,7 +853,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."
@@ -964,6 +988,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)