diff options
Diffstat (limited to 'guix')
| -rw-r--r-- | guix/scripts/publish.scm | 82 |
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) |