me/guix
Archived
1
0
Fork 0
Code Activity

substitute: Use SRFI-71 instead of SRFI-11.

Browse source 
* guix/scripts/substitute.scm (display-narinfo-data)
(open-connection-for-uri/cached)
(process-substitution): Use SRFI-71 instead of SRFI-11.
This commit is contained in:
Ludovic Courtès 2022-06-26 23:07:39 +02:00
parent f99f00fc81
commit afc490b957
No known key found for this signature in database
GPG key ID: 090B11993D9AEBB5
1 changed files with 49 additions and 51 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

100
guix/scripts/substitute.scm
View file

@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU ;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2013-2022 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2014 Nikita Karetnikov <nikita@karetnikov.org> ;;; Copyright © 2014 Nikita Karetnikov <nikita@karetnikov.org>
;;; Copyright © 2018 Kyle Meyer <kyle@kyleam.com> ;;; Copyright © 2018 Kyle Meyer <kyle@kyleam.com>
;;; Copyright © 2020 Christopher Baines <mail@cbaines.net> ;;; Copyright © 2020 Christopher Baines <mail@cbaines.net>
@ -55,11 +55,11 @@
#:use-module (ice-9 ftw) #:use-module (ice-9 ftw)
#:use-module (rnrs bytevectors) #:use-module (rnrs bytevectors)
#:use-module (srfi srfi-1) #:use-module (srfi srfi-1)
#:use-module (srfi srfi-11)
#:use-module (srfi srfi-19) #:use-module (srfi srfi-19)
#:use-module (srfi srfi-26) #:use-module (srfi srfi-26)
#:use-module (srfi srfi-34) #:use-module (srfi srfi-34)
#:use-module (srfi srfi-35) #:use-module (srfi srfi-35)
#:use-module (srfi srfi-71)
#:use-module (web uri) #:use-module (web uri)
#:use-module (guix http-client) #:use-module (guix http-client)
#:export (%allow-unauthenticated-substitutes? #:export (%allow-unauthenticated-substitutes?
@ -293,10 +293,10 @@ daemon."
(for-each (cute format port "~a/~a~%" (%store-prefix) <>) (for-each (cute format port "~a/~a~%" (%store-prefix) <>)
(narinfo-references narinfo)) (narinfo-references narinfo))
(let-values (((uri compression file-size) (let ((uri compression file-size
(narinfo-best-uri narinfo (narinfo-best-uri narinfo
#:fast-decompression? #:fast-decompression?
%prefer-fast-decompression?))) %prefer-fast-decompression?)))
(format port "~a\n~a\n" (format port "~a\n~a\n"
(or file-size 0) (or file-size 0)
(or (narinfo-size narinfo) 0)))) (or (narinfo-size narinfo) 0))))
@ -378,13 +378,13 @@ server certificates."
(#f (#f
;; Open a new connection to URI and evict old entries from ;; Open a new connection to URI and evict old entries from
;; CACHE, if any. ;; CACHE, if any.
(let-values (((socket) (let ((socket
(guix:open-connection-for-uri (guix:open-connection-for-uri
uri uri
#:verify-certificate? verify-certificate? #:verify-certificate? verify-certificate?
#:timeout timeout)) #:timeout timeout))
((new-cache evicted) (new-cache evicted
(at-most (- %max-cached-connections 1) cache))) (at-most (- %max-cached-connections 1) cache)))
(for-each (match-lambda (for-each (match-lambda
((_ . port) ((_ . port)
(false-if-exception (close-port port)))) (false-if-exception (close-port port))))
@ -494,49 +494,47 @@ PORT."
(leave (G_ "no valid substitute for '~a'~%") (leave (G_ "no valid substitute for '~a'~%")
store-item)) store-item))
(let-values (((uri compression file-size) (let ((uri compression file-size
(narinfo-best-uri narinfo (narinfo-best-uri narinfo
#:fast-decompression? #:fast-decompression?
%prefer-fast-decompression?))) %prefer-fast-decompression?)))
(unless print-build-trace? (unless print-build-trace?
(format (current-error-port) (format (current-error-port)
(G_ "Downloading ~a...~%") (uri->string uri))) (G_ "Downloading ~a...~%") (uri->string uri)))
(let*-values (((raw download-size) (let* ((raw download-size
;; 'guix publish' without '--cache' doesn't specify a ;; 'guix publish' without '--cache' doesn't specify a
;; Content-Length, so DOWNLOAD-SIZE is #f in this case. ;; Content-Length, so DOWNLOAD-SIZE is #f in this case.
(fetch uri)) (fetch uri))
((progress) (progress
(let* ((dl-size (or download-size (let* ((dl-size (or download-size
(and (equal? compression "none") (and (equal? compression "none")
(narinfo-size narinfo)))) (narinfo-size narinfo))))
(reporter (if print-build-trace? (reporter (if print-build-trace?
(progress-reporter/trace (progress-reporter/trace
destination destination
(uri->string uri) dl-size (uri->string uri) dl-size
(current-error-port)) (current-error-port))
(progress-reporter/file (progress-reporter/file
(uri->string uri) dl-size (uri->string uri) dl-size
(current-error-port) (current-error-port)
#:abbreviation nar-uri-abbreviation)))) #:abbreviation nar-uri-abbreviation))))
;; Keep RAW open upon completion so we can later reuse ;; Keep RAW open upon completion so we can later reuse
;; the underlying connection. Pass the download size so ;; the underlying connection. Pass the download size so
;; that this procedure won't block reading from RAW. ;; that this procedure won't block reading from RAW.
(progress-report-port reporter raw (progress-report-port reporter raw
#:close? #f #:close? #f
#:download-size dl-size))) #:download-size dl-size)))
((input pids) (input pids
;; NOTE: This 'progress' port of current process will be ;; NOTE: This 'progress' port of current process will be
;; closed here, while the child process doing the ;; closed here, while the child process doing the
;; reporting will close it upon exit. ;; reporting will close it upon exit.
(decompressed-port (string->symbol compression) (decompressed-port (string->symbol compression)
progress)) progress))
;; Compute the actual nar hash as we read it. ;; Compute the actual nar hash as we read it.
((algorithm expected) (algorithm expected (narinfo-hash-algorithm+value narinfo))
(narinfo-hash-algorithm+value narinfo)) (hashed get-hash (open-hash-input-port algorithm input)))
((hashed get-hash)
(open-hash-input-port algorithm input)))
;; Unpack the Nar at INPUT into DESTINATION. ;; Unpack the Nar at INPUT into DESTINATION.
(define cpu-usage (define cpu-usage
(with-cpu-usage-monitoring (with-cpu-usage-monitoring