me
/
guix
Archived
1
0
Fork 0
Code

publish: Send uncached narinfo replies from the main thread. 

Fixes <https://issues.guix.gnu.org/54723>.
Reported by Guillaume Le Vaillant <glv@posteo.net>.

Regression introduced in f743f2046b.

With commit f743f2046b, responses to
pipelined GETs would end up being written concurrently by many threads.
Thus the body of those responses could be interleaved and garbled.

* guix/scripts/publish.scm: Revert
f743f2046b.
* tests/publish.scm ("/*.narinfo pipeline"): New test.
master
Ludovic Courtès 2022-04-29 17:56:30 +02:00
parent 73eeeeafbb
commit c1719a0adf
No known key found for this signature in database
GPG Key ID: 090B11993D9AEBB5
2 changed files with 36 additions and 69 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

82
guix/scripts/publish.scm
View File

@ -25,7 +25,6 @@
#:use-module ((system repl server) #:prefix repl:) #:use-module ((system repl server) #:prefix repl:)
#:use-module (ice-9 binary-ports) #:use-module (ice-9 binary-ports)
#:use-module (ice-9 format) #:use-module (ice-9 format)
#:use-module (ice-9 iconv)
#:use-module (ice-9 match) #:use-module (ice-9 match)
#:use-module (ice-9 poll) #:use-module (ice-9 poll)
#:use-module (ice-9 regex) #:use-module (ice-9 regex)
@ -406,18 +405,15 @@ appropriate duration. NAR-PATH specifies the prefix for nar URLs."
(let ((store-path (hash-part->path store hash))) (let ((store-path (hash-part->path store hash)))
(if (string-null? store-path) (if (string-null? store-path)
(not-found request #:phrase "" #:ttl negative-ttl) (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 ,@(if ttl
`((cache-control (max-age . ,ttl))) `((cache-control (max-age . ,ttl)))
'())) '()))
;; Do not call narinfo-string directly here as it is an (cut display
;; expensive call that could potentially block the main (narinfo-string store store-path
;; thread. Instead, create the narinfo string in the #:nar-path nar-path
;; http-write procedure. #:compressions compressions)
store-path)))) <>)))))
(define* (nar-cache-file directory item (define* (nar-cache-file directory item
#:key (compression %no-compression)) #:key (compression %no-compression))
@ -672,38 +668,19 @@ requested using POOL."
(link narinfo other))) (link narinfo other)))
others)))))) 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 ;; XXX: Declare the 'X-Nar-Compression' HTTP header, which is in fact for
;; internal consumption: it allows us to pass the compression info to ;; internal consumption: it allows us to pass the compression info to
;; 'http-write', as part of the workaround to <http://bugs.gnu.org/21093>. ;; 'http-write', as part of the workaround to <http://bugs.gnu.org/21093>.
(declare-header! "X-Nar-Compression" (declare-header! "X-Nar-Compression"
(lambda (str) (lambda (str)
(sexp->compression (match (call-with-input-string str read)
(call-with-input-string str read))) (('compression type level)
(compression type level))))
compression? compression?
(lambda (compression port) (lambda (compression port)
(write (compression->sexp compression) port))) (match compression
(($ <compression> type level)
;; This header is used to pass the supported compressions to http-write in (write `(compression ,type ,level) port)))))
;; 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 (define* (render-nar store request store-item
#:key (compression %no-compression)) #:key (compression %no-compression))
@ -858,8 +835,7 @@ example: \"/foo/bar\" yields '(\"foo\" \"bar\")."
"Return RESPONSE's headers minus 'Content-Length' and our internal headers." "Return RESPONSE's headers minus 'Content-Length' and our internal headers."
(fold alist-delete (fold alist-delete
(response-headers response) (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) (define (sans-content-length response)
"Return RESPONSE without its 'content-length' header." "Return RESPONSE without its 'content-length' header."
@ -993,38 +969,6 @@ blocking."
(unless keep-alive? (unless keep-alive?
(close-port client))) (close-port client)))
(values)))))) (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) (match (assoc-ref (response-headers response) 'x-raw-file)
((? string? file) ((? string? file)

23
tests/publish.scm
View File

@ -41,12 +41,15 @@
#:autoload (zstd) (call-with-zstd-input-port) #:autoload (zstd) (call-with-zstd-input-port)
#:use-module (web uri) #:use-module (web uri)
#:use-module (web client) #:use-module (web client)
#:use-module (web request)
#:use-module (web response) #:use-module (web response)
#:use-module ((guix http-client) #:select (http-multiple-get))
#:use-module (rnrs bytevectors) #:use-module (rnrs bytevectors)
#:use-module (ice-9 binary-ports) #:use-module (ice-9 binary-ports)
#:use-module (srfi srfi-1) #:use-module (srfi srfi-1)
#:use-module (srfi srfi-26) #:use-module (srfi srfi-26)
#:use-module (srfi srfi-64) #:use-module (srfi srfi-64)
#:use-module (srfi srfi-71)
#:use-module (ice-9 threads) #:use-module (ice-9 threads)
#:use-module (ice-9 format) #:use-module (ice-9 format)
#:use-module (ice-9 match) #:use-module (ice-9 match)
@ -166,6 +169,26 @@ FileSize: ~a\n"
(publish-uri (publish-uri
(string-append "/" (store-path-hash-part %item) ".narinfo"))))) (string-append "/" (store-path-hash-part %item) ".narinfo")))))
(test-equal "/*.narinfo pipeline"
(make-list 500 200)
;; Make sure clients can pipeline requests and correct responses, in the
;; right order. See <https://issues.guix.gnu.org/54723>.
(let* ((uri (string->uri (publish-uri
(string-append "/"
(store-path-hash-part %item)
".narinfo"))))
(_ expected (http-get uri #:streaming? #f #:decode-body? #f)))
(http-multiple-get (string->uri (publish-uri ""))
(lambda (request response port result)
(and (bytevector=? expected
(get-bytevector-n port
(response-content-length
response)))
(cons (response-code response) result)))
'()
(make-list 500 (build-request uri))
#:batch-size 77)))
(test-equal "/*.narinfo with properly encoded '+' sign" (test-equal "/*.narinfo with properly encoded '+' sign"
;; See <http://bugs.gnu.org/21888>. ;; See <http://bugs.gnu.org/21888>.
(let* ((item (add-text-to-store %store "fake-gtk+" "Congrats!")) (let* ((item (add-text-to-store %store "fake-gtk+" "Congrats!"))