me/guix
Archived
1
0
Fork 0
Code Activity

store: Use buffered I/O for all protocol writes

Browse source 
* guix/store.scm (run-gc) Use buffered output port.
(export-path) Same.
(add-file-tree-to-store) Same.
(set-build-options): Same. Add explicit flush.

Signed-off-by: Ludovic Courtès <ludo@gnu.org>
This commit is contained in:
Lars-Dominik Braun 2020-06-05 10:38:32 +02:00 • committed by Ludovic Courtès
parent ea80cdbcea
commit 7a45b5d5ba
No known key found for this signature in database
GPG key ID: 090B11993D9AEBB5
1 changed files with 39 additions and 31 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

70
guix/store.scm
View file

@ -3,6 +3,7 @@
;;; Copyright © 2018 Jan Nieuwenhuizen <janneke@gnu.org> ;;; Copyright © 2018 Jan Nieuwenhuizen <janneke@gnu.org>
;;; Copyright © 2019, 2020 Mathieu Othacehe <m.othacehe@gmail.com> ;;; Copyright © 2019, 2020 Mathieu Othacehe <m.othacehe@gmail.com>
;;; Copyright © 2020 Florian Pelz <pelzflorian@pelzflorian.de> ;;; Copyright © 2020 Florian Pelz <pelzflorian@pelzflorian.de>
;;; Copyright © 2020 Lars-Dominik Braun <ldb@leibniz-psychology.org>
;;; ;;;
;;; This file is part of GNU Guix. ;;; This file is part of GNU Guix.
;;; ;;;
@ -821,8 +822,8 @@ encoding conversion errors."
(locale (false-if-exception (setlocale LC_ALL)))) (locale (false-if-exception (setlocale LC_ALL))))
;; Must be called after `open-connection'. ;; Must be called after `open-connection'.
(define socket (define buffered
(store-connection-socket server)) (store-connection-output-port server))
(unless (unspecified? use-build-hook?) (unless (unspecified? use-build-hook?)
(warn-about-deprecation #:use-build-hook? #f (warn-about-deprecation #:use-build-hook? #f
@ -831,9 +832,9 @@ encoding conversion errors."
(let-syntax ((send (syntax-rules () (let-syntax ((send (syntax-rules ()
((_ (type option) ...) ((_ (type option) ...)
(begin (begin
(write-arg type option socket) (write-arg type option buffered)
...))))) ...)))))
(write-int (operation-id set-options) socket) (write-int (operation-id set-options) buffered)
(send (boolean keep-failed?) (boolean keep-going?) (send (boolean keep-failed?) (boolean keep-going?)
(boolean fallback?) (integer verbosity)) (boolean fallback?) (integer verbosity))
(when (< (store-connection-minor-version server) #x61) (when (< (store-connection-minor-version server) #x61)
@ -896,6 +897,7 @@ encoding conversion errors."
`(("locale" . ,locale)) `(("locale" . ,locale))
'())))) '()))))
(send (string-pairs pairs)))) (send (string-pairs pairs))))
(write-buffered-output server)
(let loop ((done? (process-stderr server))) (let loop ((done? (process-stderr server)))
(or done? (process-stderr server))))) (or done? (process-stderr server)))))
@ -1108,13 +1110,14 @@ path."
;; We don't use the 'operation' macro so we can pass SELECT? to ;; We don't use the 'operation' macro so we can pass SELECT? to
;; 'write-file'. ;; 'write-file'.
(record-operation 'add-to-store) (record-operation 'add-to-store)
(let ((port (store-connection-socket server))) (let ((port (store-connection-socket server))
(write-int (operation-id add-to-store) port) (buffered (store-connection-output-port server)))
(write-string basename port) (write-int (operation-id add-to-store) buffered)
(write-int 1 port) ;obsolete, must be #t (write-string basename buffered)
(write-int (if recursive? 1 0) port) (write-int 1 buffered) ;obsolete, must be #t
(write-string hash-algo port) (write-int (if recursive? 1 0) buffered)
(write-file file-name port #:select? select?) (write-string hash-algo buffered)
(write-file file-name buffered #:select? select?)
(write-buffered-output server) (write-buffered-output server)
(let loop ((done? (process-stderr server))) (let loop ((done? (process-stderr server)))
(or done? (loop (process-stderr server)))) (or done? (loop (process-stderr server))))
@ -1220,13 +1223,14 @@ an arbitrary directory layout in the store without creating a derivation."
;; We don't use the 'operation' macro so we can use 'write-file-tree' ;; We don't use the 'operation' macro so we can use 'write-file-tree'
;; instead of 'write-file'. ;; instead of 'write-file'.
(record-operation 'add-to-store/tree) (record-operation 'add-to-store/tree)
(let ((port (store-connection-socket server))) (let ((port (store-connection-socket server))
(write-int (operation-id add-to-store) port) (buffered (store-connection-output-port server)))
(write-string basename port) (write-int (operation-id add-to-store) buffered)
(write-int 1 port) ;obsolete, must be #t (write-string basename buffered)
(write-int (if recursive? 1 0) port) (write-int 1 buffered) ;obsolete, must be #t
(write-string hash-algo port) (write-int (if recursive? 1 0) buffered)
(write-file-tree basename port (write-string hash-algo buffered)
(write-file-tree basename buffered
#:file-type+size file-type+size #:file-type+size file-type+size
#:file-port file-port #:file-port file-port
#:symlink-target symlink-target #:symlink-target symlink-target
@ -1644,17 +1648,19 @@ the list of store paths to delete. IGNORE-LIVENESS? should always be
#f. MIN-FREED is the minimum amount of disk space to be freed, in #f. MIN-FREED is the minimum amount of disk space to be freed, in
bytes, before the GC can stop. Return the list of store paths delete, bytes, before the GC can stop. Return the list of store paths delete,
and the number of bytes freed." and the number of bytes freed."
(let ((s (store-connection-socket server))) (let ((s (store-connection-socket server))
(write-int (operation-id collect-garbage) s) (buffered (store-connection-output-port server)))
(write-int action s) (write-int (operation-id collect-garbage) buffered)
(write-store-path-list to-delete s) (write-int action buffered)
(write-arg boolean #f s) ; ignore-liveness? (write-store-path-list to-delete buffered)
(write-long-long min-freed s) (write-arg boolean #f buffered) ; ignore-liveness?
(write-int 0 s) ; obsolete (write-long-long min-freed buffered)
(write-int 0 buffered) ; obsolete
(when (>= (store-connection-minor-version server) 5) (when (>= (store-connection-minor-version server) 5)
;; Obsolete `use-atime' and `max-atime' parameters. ;; Obsolete `use-atime' and `max-atime' parameters.
(write-int 0 s) (write-int 0 buffered)
(write-int 0 s)) (write-int 0 buffered))
(write-buffered-output server)
;; Loop until the server is done sending error output. ;; Loop until the server is done sending error output.
(let loop ((done? (process-stderr server))) (let loop ((done? (process-stderr server)))
@ -1711,10 +1717,12 @@ is raised if the set of paths read from PORT is not signed (as per
(define* (export-path server path port #:key (sign? #t)) (define* (export-path server path port #:key (sign? #t))
"Export PATH to PORT. When SIGN? is true, sign it." "Export PATH to PORT. When SIGN? is true, sign it."
(let ((s (store-connection-socket server))) (let ((s (store-connection-socket server))
(write-int (operation-id export-path) s) (buffered (store-connection-output-port server)))
(write-store-path path s) (write-int (operation-id export-path) buffered)
(write-arg boolean sign? s) (write-store-path path buffered)
(write-arg boolean sign? buffered)
(write-buffered-output server)
(let loop ((done? (process-stderr server port))) (let loop ((done? (process-stderr server port)))
(or done? (loop (process-stderr server port)))) (or done? (loop (process-stderr server port))))
(= 1 (read-int s)))) (= 1 (read-int s))))