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.

4 files changed, 160 insertions, 41 deletions

diff --git a/guix/scripts/challenge.scm b/guix/scripts/challenge.scm
index 65de42053d..17e87f0291 100644
--- a/guix/scripts/challenge.scm
+++ b/guix/scripts/challenge.scm
@@ -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))
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)
diff --git a/guix/scripts/weather.scm b/guix/scripts/weather.scm
index 78b8674e0c..1701772bc1 100644
--- a/guix/scripts/weather.scm
+++ b/guix/scripts/weather.scm
@@ -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)~%")
diff --git a/tests/substitute.scm b/tests/substitute.scm
index f4f2e9512d..ff2be662be 100644
--- a/tests/substitute.scm
+++ b/tests/substitute.scm
@@ -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: