diff options
| -rw-r--r-- | guix/scripts/publish.scm | 82 | ||||
| -rw-r--r-- | tests/publish.scm | 23 |
2 files changed, 36 insertions, 69 deletions
diff --git a/guix/scripts/publish.scm b/guix/scripts/publish.scm index e8197eb47a..3bf3bd9c7c 100644 --- a/guix/scripts/publish.scm +++ b/guix/scripts/publish.scm @@ -25,7 +25,6 @@ #: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) @@ -406,18 +405,15 @@ 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 - (charset . "UTF-8"))) - (x-nar-path . ,nar-path) - (x-narinfo-compressions . ,compressions) + (values `((content-type . (application/x-nix-narinfo)) ,@(if ttl `((cache-control (max-age . ,ttl))) '())) - ;; 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)))) + (cut display + (narinfo-string store store-path + #:nar-path nar-path + #:compressions compressions) + <>))))) (define* (nar-cache-file directory item #:key (compression %no-compression)) @@ -672,38 +668,19 @@ 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) - (sexp->compression - (call-with-input-string str read))) + (match (call-with-input-string str read) + (('compression type level) + (compression type level)))) compression? (lambda (compression 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))) + (match compression + (($ <compression> type level) + (write `(compression ,type ,level) port))))) (define* (render-nar store request store-item #: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." (fold alist-delete (response-headers response) - '(content-length x-raw-file x-nar-compression - x-narinfo-compressions x-nar-path))) + '(content-length x-raw-file x-nar-compression))) (define (sans-content-length response) "Return RESPONSE without its 'content-length' header." @@ -993,38 +969,6 @@ 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) diff --git a/tests/publish.scm b/tests/publish.scm index 47c5eabca0..efb5698bed 100644 --- a/tests/publish.scm +++ b/tests/publish.scm @@ -41,12 +41,15 @@ #:autoload (zstd) (call-with-zstd-input-port) #:use-module (web uri) #:use-module (web client) + #:use-module (web request) #:use-module (web response) + #:use-module ((guix http-client) #:select (http-multiple-get)) #:use-module (rnrs bytevectors) #:use-module (ice-9 binary-ports) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) #:use-module (srfi srfi-64) + #:use-module (srfi srfi-71) #:use-module (ice-9 threads) #:use-module (ice-9 format) #:use-module (ice-9 match) @@ -166,6 +169,26 @@ FileSize: ~a\n" (publish-uri (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" ;; See <http://bugs.gnu.org/21888>. (let* ((item (add-text-to-store %store "fake-gtk+" "Congrats!")) |