me
/
guix
Archived
1
0
Fork 0
Code

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.
master
Ludovic Courtès 2019-05-31 16:26:08 +02:00
parent b8fa86adfc
commit b90ae065b5
No known key found for this signature in database
GPG Key ID: 090B11993D9AEBB5
4 changed files with 160 additions and 41 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
guix/scripts/challenge.scm
View File

@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2015, 2016, 2017, 2019 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
@ -192,7 +192,7 @@ inconclusive reports."
(report (G_ " no local build for '~a'~%") item))
(for-each (lambda (narinfo)
(report (G_ " ~50a: ~a~%")
(uri->string (narinfo-uri narinfo))
(uri->string (first (narinfo-uris narinfo)))
(hash->string
(narinfo-hash->sha256 (narinfo-hash narinfo)))))
narinfos))

141
guix/scripts/substitute.scm
View File

@ -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)

5
guix/scripts/weather.scm
View File

@ -175,7 +175,10 @@ about the derivations queued, as is the case with Hydra."
(requested (length items))
(missing (lset-difference string=?
items (map narinfo-path narinfos)))
(sizes (filter-map narinfo-file-size narinfos))
(sizes (append-map (lambda (narinfo)
(filter integer?
(narinfo-file-sizes narinfo)))
narinfos))
(time (+ (time-second time)
(/ (time-nanosecond time) 1e9))))
(format #t (G_ " ~2,1f% substitutes available (~h out of ~h)~%")

51
tests/substitute.scm
View File

@ -28,8 +28,10 @@
#:use-module (guix base32)
#:use-module ((guix store) #:select (%store-prefix))
#:use-module ((guix ui) #:select (guix-warning-port))
#:use-module ((guix utils) #:select (call-with-compressed-output-port))
#:use-module ((guix lzlib) #:select (lzlib-available?))
#:use-module ((guix build utils)
#:select (mkdir-p delete-file-recursively))
#:select (mkdir-p delete-file-recursively dump-port))
#:use-module (guix tests http)
#:use-module (rnrs bytevectors)
#:use-module (rnrs io ports)
@ -475,6 +477,53 @@ System: mips64el-linux\n")
"/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
"substitute-retrieved"))))
(test-equal "substitute, narinfo with several URLs"
"Substitutable data."
(let ((narinfo (string-append "StorePath: " (%store-prefix)
"/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo
URL: example.nar.gz
Compression: gzip
URL: example.nar.lz
Compression: lzip
URL: example.nar
Compression: none
NarHash: sha256:" (bytevector->nix-base32-string
(sha256 (string->utf8 "Substitutable data."))) "
NarSize: 42
References: bar baz
Deriver: " (%store-prefix) "/foo.drv
System: mips64el-linux\n")))
(with-narinfo (string-append narinfo "Signature: "
(signature-field narinfo))
(dynamic-wind
(const #t)
(lambda ()
(define (compress input output compression)
(call-with-output-file output
(lambda (port)
(call-with-compressed-output-port compression port
(lambda (port)
(call-with-input-file input
(lambda (input)
(dump-port input port))))))))
(let ((nar (string-append %main-substitute-directory
"/example.nar")))
(compress nar (string-append nar ".gz") 'gzip)
(when (lzlib-available?)
(compress nar (string-append nar ".lz") 'lzip)))
(parameterize ((substitute-urls
(list (string-append "file://"
%main-substitute-directory))))
(guix-substitute "--substitute"
(string-append (%store-prefix)
"/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
"substitute-retrieved"))
(call-with-input-file "substitute-retrieved" get-string-all))
(lambda ()
(false-if-exception (delete-file "substitute-retrieved")))))))
(test-end "substitute")
;;; Local Variables: