summaryrefslogtreecommitdiff
path: root/guix/scripts/substitute.scm
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2019-05-31 16:26:08 +0200
committerLudovic Courtès <ludo@gnu.org>2019-06-02 22:01:57 +0200
commitb90ae065b5a5fab4ed475bf2faa3a84476389a02 (patch)
tree306c6a49fbeb2e87d77dd2d023cc0c2a94a34afd /guix/scripts/substitute.scm
parentb8fa86adfc01205f1d942af8cb57515eb3726c52 (diff)
substitute: Select the best compression methods.
When a server publishes several URLs with different compression methods, 'guix substitute' can now choose the best one among the compression methods that it supports. * guix/scripts/substitute.scm (<narinfo>)[uri]: Replace with... [uris]: ... this. [compression]: Replace with... [compressions]: ... this. [file-size]: Replace with... [file-sizes]: ... this. [file-hash]: Replace with... [file-hashes]: ... this. (narinfo-maker): Adjust accordingly. Ensure 'file-sizes' and 'file-hashes' have the right length. (assert-valid-signature, valid-narinfo?): Use the first element of 'narinfo-uris' in error messages. (read-narinfo): Expect "URL", "Compression", "FileSize", and "FileHash" to occur multiple times. (display-narinfo-data): Call 'select-uri' to determine the file size. (%compression-methods): New variable. (supported-compression?, compresses-better?, select-uri): New procedures. (process-substitution): Call 'select-uri' to select the URI and compression. * guix/scripts/weather.scm (report-server-coverage): Account for all the values returned by 'narinfo-file-sizes'. * tests/substitute.scm ("substitute, narinfo with several URLs"): New test.
Diffstat (limited to 'guix/scripts/substitute.scm')
-rwxr-xr-xguix/scripts/substitute.scm141
1 files changed, 104 insertions, 37 deletions
diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm
index 135398ba48..dba08edf50 100755
--- a/guix/scripts/substitute.scm
+++ b/guix/scripts/substitute.scm
@@ -42,6 +42,7 @@
#:use-module (guix progress)
#:use-module ((guix build syscalls)
#:select (set-thread-name))
+ #:autoload (guix lzlib) (lzlib-available?)
#:use-module (ice-9 rdelim)
#:use-module (ice-9 regex)
#:use-module (ice-9 match)
@@ -66,11 +67,11 @@
narinfo?
narinfo-path
- narinfo-uri
+ narinfo-uris
narinfo-uri-base
- narinfo-compression
- narinfo-file-hash
- narinfo-file-size
+ narinfo-compressions
+ narinfo-file-hashes
+ narinfo-file-sizes
narinfo-hash
narinfo-size
narinfo-references
@@ -280,15 +281,16 @@ failure, return #f and #f."
(define-record-type <narinfo>
- (%make-narinfo path uri uri-base compression file-hash file-size nar-hash nar-size
- references deriver system signature contents)
+ (%make-narinfo path uri-base uris compressions file-sizes file-hashes
+ nar-hash nar-size references deriver system
+ signature contents)
narinfo?
(path narinfo-path)
- (uri narinfo-uri)
- (uri-base narinfo-uri-base) ; URI of the cache it originates from
- (compression narinfo-compression)
- (file-hash narinfo-file-hash)
- (file-size narinfo-file-size)
+ (uri-base narinfo-uri-base) ;URI of the cache it originates from
+ (uris narinfo-uris) ;list of strings
+ (compressions narinfo-compressions) ;list of strings
+ (file-sizes narinfo-file-sizes) ;list of (integers | #f)
+ (file-hashes narinfo-file-hashes)
(nar-hash narinfo-hash)
(nar-size narinfo-size)
(references narinfo-references)
@@ -334,17 +336,25 @@ s-expression: ~s~%")
(define (narinfo-maker str cache-url)
"Return a narinfo constructor for narinfos originating from CACHE-URL. STR
must contain the original contents of a narinfo file."
- (lambda (path url compression file-hash file-size nar-hash nar-size
- references deriver system signature)
+ (lambda (path urls compressions file-hashes file-sizes
+ nar-hash nar-size references deriver system
+ signature)
"Return a new <narinfo> object."
- (%make-narinfo path
+ (define len (length urls))
+ (%make-narinfo path cache-url
;; Handle the case where URL is a relative URL.
- (or (string->uri url)
- (string->uri (string-append cache-url "/" url)))
- cache-url
-
- compression file-hash
- (and=> file-size string->number)
+ (map (lambda (url)
+ (or (string->uri url)
+ (string->uri
+ (string-append cache-url "/" url))))
+ urls)
+ compressions
+ (match file-sizes
+ (() (make-list len #f))
+ ((lst ...) (map string->number lst)))
+ (match file-hashes
+ (() (make-list len #f))
+ ((lst ...) (map string->number lst)))
nar-hash
(and=> nar-size string->number)
(string-tokenize references)
@@ -360,7 +370,7 @@ must contain the original contents of a narinfo file."
#:optional (acl (current-acl)))
"Bail out if SIGNATURE, a canonical sexp representing the signature of
NARINFO, doesn't match HASH, a bytevector containing the hash of NARINFO."
- (let ((uri (uri->string (narinfo-uri narinfo))))
+ (let ((uri (uri->string (first (narinfo-uris narinfo)))))
(signature-case (signature hash acl)
(valid-signature #t)
(invalid-signature
@@ -387,7 +397,8 @@ No authentication and authorization checks are performed here!"
'("StorePath" "URL" "Compression"
"FileHash" "FileSize" "NarHash" "NarSize"
"References" "Deriver" "System"
- "Signature"))))
+ "Signature")
+ '("URL" "Compression" "FileSize" "FileHash"))))
(define (narinfo-sha256 narinfo)
"Return the sha256 hash of NARINFO as a bytevector, or #f if NARINFO lacks a
@@ -414,7 +425,7 @@ No authentication and authorization checks are performed here!"
(or %allow-unauthenticated-substitutes?
(let ((hash (narinfo-sha256 narinfo))
(signature (narinfo-signature narinfo))
- (uri (uri->string (narinfo-uri narinfo))))
+ (uri (uri->string (first (narinfo-uris narinfo)))))
(and hash signature
(signature-case (signature hash acl)
(valid-signature #t)
@@ -919,9 +930,11 @@ expected by the daemon."
(length (narinfo-references narinfo)))
(for-each (cute format #t "~a/~a~%" (%store-prefix) <>)
(narinfo-references narinfo))
- (format #t "~a\n~a\n"
- (or (narinfo-file-size narinfo) 0)
- (or (narinfo-size narinfo) 0)))
+
+ (let-values (((uri compression file-size) (select-uri narinfo)))
+ (format #t "~a\n~a\n"
+ (or file-size 0)
+ (or (narinfo-size narinfo) 0))))
(define* (process-query command
#:key cache-urls acl)
@@ -947,17 +960,73 @@ authorized substitutes."
(wtf
(error "unknown `--query' command" wtf))))
+(define %compression-methods
+ ;; Known compression methods and a thunk to determine whether they're
+ ;; supported. See 'decompressed-port' in (guix utils).
+ `(("gzip" . ,(const #t))
+ ("lzip" . ,lzlib-available?)
+ ("xz" . ,(const #t))
+ ("bzip2" . ,(const #t))
+ ("none" . ,(const #t))))
+
+(define (supported-compression? compression)
+ "Return true if COMPRESSION, a string, denotes a supported compression
+method."
+ (match (assoc-ref %compression-methods compression)
+ (#f #f)
+ (supported? (supported?))))
+
+(define (compresses-better? compression1 compression2)
+ "Return true if COMPRESSION1 generally compresses better than COMPRESSION2;
+this is a rough approximation."
+ (match compression1
+ ("none" #f)
+ ("gzip" (string=? compression2 "none"))
+ (_ (or (string=? compression2 "none")
+ (string=? compression2 "gzip")))))
+
+(define (select-uri narinfo)
+ "Select the \"best\" URI to download NARINFO's nar, and return three values:
+the URI, its compression method (a string), and the compressed file size."
+ (define choices
+ (filter (match-lambda
+ ((uri compression file-size)
+ (supported-compression? compression)))
+ (zip (narinfo-uris narinfo)
+ (narinfo-compressions narinfo)
+ (narinfo-file-sizes narinfo))))
+
+ (define (file-size<? c1 c2)
+ (match c1
+ ((uri1 compression1 (? integer? file-size1))
+ (match c2
+ ((uri2 compression2 (? integer? file-size2))
+ (< file-size1 file-size2))
+ (_ #t)))
+ ((uri compression1 #f)
+ (match c2
+ ((uri2 compression2 _)
+ (compresses-better? compression1 compression2))))
+ (_ #f))) ;we can't tell
+
+ (match (sort choices file-size<?)
+ (((uri compression file-size) _ ...)
+ (values uri compression file-size))))
+
(define* (process-substitution store-item destination
#:key cache-urls acl print-build-trace?)
"Substitute STORE-ITEM (a store file name) from CACHE-URLS, and write it to
DESTINATION as a nar file. Verify the substitute against ACL."
- (let* ((narinfo (lookup-narinfo cache-urls store-item
- (cut valid-narinfo? <> acl)))
- (uri (and=> narinfo narinfo-uri)))
- (unless uri
- (leave (G_ "no valid substitute for '~a'~%")
- store-item))
+ (define narinfo
+ (lookup-narinfo cache-urls store-item
+ (cut valid-narinfo? <> acl)))
+
+ (unless narinfo
+ (leave (G_ "no valid substitute for '~a'~%")
+ store-item))
+ (let-values (((uri compression file-size)
+ (select-uri narinfo)))
;; Tell the daemon what the expected hash of the Nar itself is.
(format #t "~a~%" (narinfo-hash narinfo))
@@ -971,9 +1040,8 @@ DESTINATION as a nar file. Verify the substitute against ACL."
;; DOWNLOAD-SIZE is #f in practice.
(fetch uri #:buffered? #f #:timeout? #f))
((progress)
- (let* ((comp (narinfo-compression narinfo))
- (dl-size (or download-size
- (and (equal? comp "none")
+ (let* ((dl-size (or download-size
+ (and (equal? compression "none")
(narinfo-size narinfo))))
(reporter (if print-build-trace?
(progress-reporter/trace
@@ -989,8 +1057,7 @@ DESTINATION as a nar file. Verify the substitute against ACL."
;; NOTE: This 'progress' port of current process will be
;; closed here, while the child process doing the
;; reporting will close it upon exit.
- (decompressed-port (and=> (narinfo-compression narinfo)
- string->symbol)
+ (decompressed-port (string->symbol compression)
progress)))
;; Unpack the Nar at INPUT into DESTINATION.
(restore-file input destination)