summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2022-06-26 23:07:39 +0200
committerLudovic Courtès <ludo@gnu.org>2022-06-26 23:19:14 +0200
commitafc490b957fce17202aded63a389d4401ae6d9bd (patch)
tree80b832bf5ff20949dca0037b9dfa0bcf6b63a7a1
parentstatus: Relay "updating substitutes" messages. (diff)
downloadguix-afc490b957fce17202aded63a389d4401ae6d9bd.tar.gz
guix-afc490b957fce17202aded63a389d4401ae6d9bd.tar.bz2
guix-afc490b957fce17202aded63a389d4401ae6d9bd.tar.xz
substitute: Use SRFI-71 instead of SRFI-11.
* guix/scripts/substitute.scm (display-narinfo-data) (open-connection-for-uri/cached) (process-substitution): Use SRFI-71 instead of SRFI-11.
-rwxr-xr-xguix/scripts/substitute.scm102
1 files changed, 50 insertions, 52 deletions
diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm
index c5f5d23b47..cdf591ac4d 100755
--- a/guix/scripts/substitute.scm
+++ b/guix/scripts/substitute.scm
@@ -1,5 +1,5 @@
1;;; GNU Guix --- Functional package management for GNU 1;;; GNU Guix --- Functional package management for GNU
2;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org> 2;;; Copyright © 2013-2022 Ludovic Courtès <ludo@gnu.org>
3;;; Copyright © 2014 Nikita Karetnikov <nikita@karetnikov.org> 3;;; Copyright © 2014 Nikita Karetnikov <nikita@karetnikov.org>
4;;; Copyright © 2018 Kyle Meyer <kyle@kyleam.com> 4;;; Copyright © 2018 Kyle Meyer <kyle@kyleam.com>
5;;; Copyright © 2020 Christopher Baines <mail@cbaines.net> 5;;; Copyright © 2020 Christopher Baines <mail@cbaines.net>
@@ -55,11 +55,11 @@
55 #:use-module (ice-9 ftw) 55 #:use-module (ice-9 ftw)
56 #:use-module (rnrs bytevectors) 56 #:use-module (rnrs bytevectors)
57 #:use-module (srfi srfi-1) 57 #:use-module (srfi srfi-1)
58 #:use-module (srfi srfi-11)
59 #:use-module (srfi srfi-19) 58 #:use-module (srfi srfi-19)
60 #:use-module (srfi srfi-26) 59 #:use-module (srfi srfi-26)
61 #:use-module (srfi srfi-34) 60 #:use-module (srfi srfi-34)
62 #:use-module (srfi srfi-35) 61 #:use-module (srfi srfi-35)
62 #:use-module (srfi srfi-71)
63 #:use-module (web uri) 63 #:use-module (web uri)
64 #:use-module (guix http-client) 64 #:use-module (guix http-client)
65 #:export (%allow-unauthenticated-substitutes? 65 #:export (%allow-unauthenticated-substitutes?
@@ -293,10 +293,10 @@ daemon."
293 (for-each (cute format port "~a/~a~%" (%store-prefix) <>) 293 (for-each (cute format port "~a/~a~%" (%store-prefix) <>)
294 (narinfo-references narinfo)) 294 (narinfo-references narinfo))
295 295
296 (let-values (((uri compression file-size) 296 (let ((uri compression file-size
297 (narinfo-best-uri narinfo 297 (narinfo-best-uri narinfo
298 #:fast-decompression? 298 #:fast-decompression?
299 %prefer-fast-decompression?))) 299 %prefer-fast-decompression?)))
300 (format port "~a\n~a\n" 300 (format port "~a\n~a\n"
301 (or file-size 0) 301 (or file-size 0)
302 (or (narinfo-size narinfo) 0)))) 302 (or (narinfo-size narinfo) 0))))
@@ -378,13 +378,13 @@ server certificates."
378 (#f 378 (#f
379 ;; Open a new connection to URI and evict old entries from 379 ;; Open a new connection to URI and evict old entries from
380 ;; CACHE, if any. 380 ;; CACHE, if any.
381 (let-values (((socket) 381 (let ((socket
382 (guix:open-connection-for-uri 382 (guix:open-connection-for-uri
383 uri 383 uri
384 #:verify-certificate? verify-certificate? 384 #:verify-certificate? verify-certificate?
385 #:timeout timeout)) 385 #:timeout timeout))
386 ((new-cache evicted) 386 (new-cache evicted
387 (at-most (- %max-cached-connections 1) cache))) 387 (at-most (- %max-cached-connections 1) cache)))
388 (for-each (match-lambda 388 (for-each (match-lambda
389 ((_ . port) 389 ((_ . port)
390 (false-if-exception (close-port port)))) 390 (false-if-exception (close-port port))))
@@ -494,49 +494,47 @@ PORT."
494 (leave (G_ "no valid substitute for '~a'~%") 494 (leave (G_ "no valid substitute for '~a'~%")
495 store-item)) 495 store-item))
496 496
497 (let-values (((uri compression file-size) 497 (let ((uri compression file-size
498 (narinfo-best-uri narinfo 498 (narinfo-best-uri narinfo
499 #:fast-decompression? 499 #:fast-decompression?
500 %prefer-fast-decompression?))) 500 %prefer-fast-decompression?)))
501 (unless print-build-trace? 501 (unless print-build-trace?
502 (format (current-error-port) 502 (format (current-error-port)
503 (G_ "Downloading ~a...~%") (uri->string uri))) 503 (G_ "Downloading ~a...~%") (uri->string uri)))
504 504
505 (let*-values (((raw download-size) 505 (let* ((raw download-size
506 ;; 'guix publish' without '--cache' doesn't specify a 506 ;; 'guix publish' without '--cache' doesn't specify a
507 ;; Content-Length, so DOWNLOAD-SIZE is #f in this case. 507 ;; Content-Length, so DOWNLOAD-SIZE is #f in this case.
508 (fetch uri)) 508 (fetch uri))
509 ((progress) 509 (progress
510 (let* ((dl-size (or download-size 510 (let* ((dl-size (or download-size
511 (and (equal? compression "none") 511 (and (equal? compression "none")
512 (narinfo-size narinfo)))) 512 (narinfo-size narinfo))))
513 (reporter (if print-build-trace? 513 (reporter (if print-build-trace?
514 (progress-reporter/trace 514 (progress-reporter/trace
515 destination 515 destination
516 (uri->string uri) dl-size 516 (uri->string uri) dl-size
517 (current-error-port)) 517 (current-error-port))
518 (progress-reporter/file 518 (progress-reporter/file
519 (uri->string uri) dl-size 519 (uri->string uri) dl-size
520 (current-error-port) 520 (current-error-port)
521 #:abbreviation nar-uri-abbreviation)))) 521 #:abbreviation nar-uri-abbreviation))))
522 ;; Keep RAW open upon completion so we can later reuse 522 ;; Keep RAW open upon completion so we can later reuse
523 ;; the underlying connection. Pass the download size so 523 ;; the underlying connection. Pass the download size so
524 ;; that this procedure won't block reading from RAW. 524 ;; that this procedure won't block reading from RAW.
525 (progress-report-port reporter raw 525 (progress-report-port reporter raw
526 #:close? #f 526 #:close? #f
527 #:download-size dl-size))) 527 #:download-size dl-size)))
528 ((input pids) 528 (input pids
529 ;; NOTE: This 'progress' port of current process will be 529 ;; NOTE: This 'progress' port of current process will be
530 ;; closed here, while the child process doing the 530 ;; closed here, while the child process doing the
531 ;; reporting will close it upon exit. 531 ;; reporting will close it upon exit.
532 (decompressed-port (string->symbol compression) 532 (decompressed-port (string->symbol compression)
533 progress)) 533 progress))
534 534
535 ;; Compute the actual nar hash as we read it. 535 ;; Compute the actual nar hash as we read it.
536 ((algorithm expected) 536 (algorithm expected (narinfo-hash-algorithm+value narinfo))
537 (narinfo-hash-algorithm+value narinfo)) 537 (hashed get-hash (open-hash-input-port algorithm input)))
538 ((hashed get-hash)
539 (open-hash-input-port algorithm input)))
540 ;; Unpack the Nar at INPUT into DESTINATION. 538 ;; Unpack the Nar at INPUT into DESTINATION.
541 (define cpu-usage 539 (define cpu-usage
542 (with-cpu-usage-monitoring 540 (with-cpu-usage-monitoring