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.master
Mathieu Othacehe
parent
a7028d4323
commit
f743f2046b
|
|
@ -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)
|
||||
|
|
|
|||
Reference in New Issue