TakeV/guix
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity

publish: Use 'x-raw-file' internal response header.

Browse source 
This adjusts the workaround for <http://bugs.gnu.org/21093> so that it's
not limited to a single content-type.

* guix/scripts/publish.scm (render-nar/cached): Add the 'x-raw-file'
header on the response.
(render-content-addressed-file): Likewise.
(with-content-length): Remove the 'x-raw-file' header.
(http-write): Instead of dispatching on 'application/octet-stream',
check whether 'x-raw-file' is set to determine whether to spawn a
thread.
This commit is contained in:
Ludovic Courtès 2018-01-05 00:15:51 +01:00
parent 06e3a5181e
commit 152b7beeac
No known key found for this signature in database
GPG key ID: 090B11993D9AEBB5
1 changed files with 45 additions and 41 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

86
guix/scripts/publish.scm
View file

@ -544,11 +544,12 @@ (define* (render-nar/cached store cache request store-item
#:compression compression)))
(if (file-exists? cached)
(values `((content-type . (application/octet-stream
(charset . "ISO-8859-1"))))
;; XXX: We're not returning the actual contents, deferring
;; instead to 'http-write'. This is a hack to work around
;; <http://bugs.gnu.org/21093>.
cached)
(charset . "ISO-8859-1")))
;; XXX: We're not returning the actual contents, deferring
;; instead to 'http-write'. This is a hack to work around
;; <http://bugs.gnu.org/21093>.
(x-raw-file . ,cached))
#f)
(not-found request))))
(define (render-content-addressed-file store request
@ -562,11 +563,12 @@ (define (render-content-addressed-file store request
#:recursive? #f)))
(if (valid-path? store item)
(values `((content-type . (application/octet-stream
(charset . "ISO-8859-1"))))
;; XXX: We're not returning the actual contents, deferring
;; instead to 'http-write'. This is a hack to work around
;; <http://bugs.gnu.org/21093>.
item)
(charset . "ISO-8859-1")))
;; XXX: We're not returning the actual contents,
;; deferring instead to 'http-write'. This is a hack to
;; work around <http://bugs.gnu.org/21093>.
(x-raw-file . ,item))
#f)
(not-found request)))
(not-found request)))
@ -622,9 +624,9 @@ (define (with-content-length response length)
"Return RESPONSE with a 'content-length' header set to LENGTH."
(set-field response (response-headers)
(alist-cons 'content-length length
(alist-delete 'content-length
(response-headers response)
eq?))))
(fold alist-delete
(response-headers response)
'(content-length x-raw-file)))))
(define-syntax-rule (swallow-EPIPE exp ...)
"Swallow EPIPE errors raised by EXP..."
@ -685,35 +687,37 @@ (define (http-write server client response body)
(swallow-zlib-error
(close-port port))
(values)))))
(('application/octet-stream . _)
;; Send a raw file in a separate thread.
(call-with-new-thread
(lambda ()
(set-thread-name "publish file")
(catch 'system-error
(lambda ()
(call-with-input-file (utf8->string body)
(lambda (input)
(let* ((size (stat:size (stat input)))
(response (write-response (with-content-length response
size)
client))
(output (response-port response)))
(if (file-port? output)
(sendfile output input size)
(dump-port input output))
(close-port output)
(values)))))
(lambda args
;; If the file was GC'd behind our back, that's fine. Likewise if
;; the client closes the connection.
(unless (memv (system-error-errno args)
(list ENOENT EPIPE ECONNRESET))
(apply throw args))
(values))))))
(_
;; Handle other responses sequentially.
(%http-write server client response body))))
(match (assoc-ref (response-headers response) 'x-raw-file)
((? string? file)
;; Send a raw file in a separate thread.
(call-with-new-thread
(lambda ()
(set-thread-name "publish file")
(catch 'system-error
(lambda ()
(call-with-input-file file
(lambda (input)
(let* ((size (stat:size (stat input)))
(response (write-response (with-content-length response
size)
client))
(output (response-port response)))
(if (file-port? output)
(sendfile output input size)
(dump-port input output))
(close-port output)
(values)))))
(lambda args
;; If the file was GC'd behind our back, that's fine. Likewise if
;; the client closes the connection.
(unless (memv (system-error-errno args)
(list ENOENT EPIPE ECONNRESET))
(apply throw args))
(values))))))
(#f
;; Handle other responses sequentially.
(%http-write server client response body))))))
(define-server-impl concurrent-http-server
;; A variant of Guile's built-in HTTP server that offloads possibly long