Merge branch 'master' into core-updates

7 files changed, 407 insertions, 197 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/offload.scm b/guix/scripts/offload.scm
index eb02672dbf..0c0dd9d516 100644
--- a/guix/scripts/offload.scm
+++ b/guix/scripts/offload.scm
@@ -236,30 +236,6 @@ instead of '~a' of type '~a'~%")
 ;;; Synchronization.
 ;;;
 
-(define (lock-file file)
-  "Wait and acquire an exclusive lock on FILE.  Return an open port."
-  (mkdir-p (dirname file))
-  (let ((port (open-file file "w0")))
-    (fcntl-flock port 'write-lock)
-    port))
-
-(define (unlock-file lock)
-  "Unlock LOCK."
-  (fcntl-flock lock 'unlock)
-  (close-port lock)
-  #t)
-
-(define-syntax-rule (with-file-lock file exp ...)
-  "Wait to acquire a lock on FILE and evaluate EXP in that context."
-  (let ((port (lock-file file)))
-    (dynamic-wind
-      (lambda ()
-        #t)
-      (lambda ()
-        exp ...)
-      (lambda ()
-        (unlock-file port)))))
-
 (define (machine-slot-file machine slot)
   "Return the file name of MACHINE's file for SLOT."
   ;; For each machine we have a bunch of files representing each build slot.
@@ -829,7 +805,6 @@ This tool is meant to be used internally by 'guix-daemon'.\n"))
      (leave (G_ "invalid arguments: ~{~s ~}~%") x))))
 
 ;;; Local Variables:
-;;; eval: (put 'with-file-lock 'scheme-indent-function 1)
 ;;; eval: (put 'with-error-to-port 'scheme-indent-function 1)
 ;;; eval: (put 'with-timeout 'scheme-indent-function 2)
 ;;; End:
diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm
index 802b26c64c..c8cb7b959d 100644
--- a/guix/scripts/pack.scm
+++ b/guix/scripts/pack.scm
@@ -152,6 +152,7 @@ dependencies are registered."
                                  #:key target
                                  (profile-name "guix-profile")
                                  deduplicate?
+                                 entry-point
                                  (compressor (first %compressors))
                                  localstatedir?
                                  (symlinks '())
@@ -275,6 +276,10 @@ added to the pack."
                                           (_ #f))
                                         directives)))))))))
 
+  (when entry-point
+    (warning (G_ "entry point not supported in the '~a' format~%")
+             'tarball))
+
   (gexp->derivation (string-append name ".tar"
                                    (compressor-extension compressor))
                     build
@@ -284,6 +289,7 @@ added to the pack."
                          #:key target
                          (profile-name "guix-profile")
                          (compressor (first %compressors))
+                         entry-point
                          localstatedir?
                          (symlinks '())
                          (archiver squashfs-tools-next))
@@ -315,6 +321,7 @@ added to the pack."
                        (ice-9 match))
 
           (define database #+database)
+          (define entry-point #$entry-point)
 
           (setenv "PATH" (string-append #$archiver "/bin"))
 
@@ -371,6 +378,28 @@ added to the pack."
                                                             target)))))))
                       '#$symlinks)
 
+                   ;; Create /.singularity.d/actions, and optionally the 'run'
+                   ;; script, used by 'singularity run'.
+                   "-p" "/.singularity.d d 555 0 0"
+                   "-p" "/.singularity.d/actions d 555 0 0"
+                   ,@(if entry-point
+                         `(;; This one if for Singularity 2.x.
+                           "-p"
+                           ,(string-append
+                             "/.singularity.d/actions/run s 777 0 0 "
+                             (relative-file-name "/.singularity.d/actions"
+                                                 (string-append #$profile "/"
+                                                                entry-point)))
+
+                           ;; This one is for Singularity 3.x.
+                           "-p"
+                           ,(string-append
+                             "/.singularity.d/runscript s 777 0 0 "
+                             (relative-file-name "/.singularity.d"
+                                                 (string-append #$profile "/"
+                                                                entry-point))))
+                         '())
+
                    ;; Create empty mount points.
                    "-p" "/proc d 555 0 0"
                    "-p" "/sys d 555 0 0"
@@ -392,6 +421,7 @@ added to the pack."
                        #:key target
                        (profile-name "guix-profile")
                        (compressor (first %compressors))
+                       entry-point
                        localstatedir?
                        (symlinks '())
                        (archiver tar))
@@ -425,6 +455,9 @@ the image."
                                 #$profile
                                 #:database #+database
                                 #:system (or #$target (utsname:machine (uname)))
+                                #:entry-point #$(and entry-point
+                                                     #~(string-append #$profile "/"
+                                                                      #$entry-point))
                                 #:symlinks '#$symlinks
                                 #:compressor '#$(compressor-command compressor)
                                 #:creation-time (make-time time-utc 0 1))))))
@@ -689,6 +722,9 @@ please email '~a'~%")
                  (lambda (opt name arg result)
                    (alist-cons 'system arg
                                (alist-delete 'system result eq?))))
+         (option '("entry-point") #t #f
+                 (lambda (opt name arg result)
+                   (alist-cons 'entry-point arg result)))
          (option '("target") #t #f
                  (lambda (opt name arg result)
                    (alist-cons 'target arg
@@ -766,6 +802,9 @@ Create a bundle of PACKAGE.\n"))
   (display (G_ "
   -m, --manifest=FILE    create a pack with the manifest from FILE"))
   (display (G_ "
+      --entry-point=PROGRAM
+                         use PROGRAM as the entry point of the pack"))
+  (display (G_ "
       --save-provenance  save provenance information"))
   (display (G_ "
       --localstatedir    include /var/guix in the resulting pack"))
@@ -889,6 +928,7 @@ Create a bundle of PACKAGE.\n"))
                                  (leave (G_ "~a: unknown pack format~%")
                                         pack-format))))
                  (localstatedir? (assoc-ref opts 'localstatedir?))
+                 (entry-point    (assoc-ref opts 'entry-point))
                  (profile-name   (assoc-ref opts 'profile-name))
                  (gc-root        (assoc-ref opts 'gc-root)))
             (when (null? (manifest-entries manifest))
@@ -919,6 +959,8 @@ Create a bundle of PACKAGE.\n"))
                                                      symlinks
                                                      #:localstatedir?
                                                      localstatedir?
+                                                     #:entry-point
+                                                     entry-point
                                                      #:profile-name
                                                      profile-name
                                                      #:archiver
diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm
index 06e4cf5b9c..5751123525 100644
--- a/guix/scripts/package.scm
+++ b/guix/scripts/package.scm
@@ -57,7 +57,6 @@
   #:export (build-and-use-profile
             delete-generations
             delete-matching-generations
-            display-search-paths
             guix-package
 
             (%options . %package-options)
@@ -169,8 +168,7 @@ hooks\" run when building the profile."
                               "~a packages in profile~%"
                               count)
                        count)
-               (display-search-paths entries (list profile)
-                                     #:kind 'prefix)))
+               (display-search-path-hint entries profile)))
 
         (warn-about-disk-space profile))))))
 
@@ -289,17 +287,23 @@ symlinks like 'canonicalize-path' would do."
       file
       (string-append (getcwd) "/" file)))
 
-(define* (display-search-paths entries profiles
-                               #:key (kind 'exact))
-  "Display the search path environment variables that may need to be set for
-ENTRIES, a list of manifest entries, in the context of PROFILE."
-  (let* ((profiles (map (compose user-friendly-profile absolutize)
-                        profiles))
-         (settings (search-path-environment-variables entries profiles
-                                                      #:kind kind)))
+(define (display-search-path-hint entries profile)
+  "Display a hint on how to set environment variables to use ENTRIES, a list
+of manifest entries, in the context of PROFILE."
+  (let* ((profile  (user-friendly-profile (absolutize profile)))
+         (settings (search-path-environment-variables entries (list profile)
+                                                      #:kind 'prefix)))
     (unless (null? settings)
-      (format #t (G_ "The following environment variable definitions may be needed:~%"))
-      (format #t "~{   ~a~%~}" settings))))
+      (display-hint (format #f (G_ "Consider setting the necessary environment
+variables by running:
+
+@example
+GUIX_PROFILE=\"~a\"
+. \"$GUIX_PROFILE/etc/profile\"
+@end example
+
+Alternately, see @command{guix package --search-paths -p ~s}.")
+                            profile profile)))))
 
 
 ;;;
diff --git a/guix/scripts/publish.scm b/guix/scripts/publish.scm
index a236f3e45c..b4334b3f16 100644
--- a/guix/scripts/publish.scm
+++ b/guix/scripts/publish.scm
@@ -1,6 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2015 David Thompson <davet@gnu.org>
-;;; Copyright © 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -51,6 +51,7 @@
   #:use-module (guix store)
   #:use-module ((guix serialization) #:select (write-file))
   #:use-module (guix zlib)
+  #:autoload   (guix lzlib) (lzlib-available?)
   #:use-module (guix cache)
   #:use-module (guix ui)
   #:use-module (guix scripts)
@@ -74,8 +75,8 @@ Publish ~a over HTTP.\n") %store-directory)
   (display (G_ "
   -u, --user=USER        change privileges to USER as soon as possible"))
   (display (G_ "
-  -C, --compression[=LEVEL]
-                         compress archives at LEVEL"))
+  -C, --compression[=METHOD:LEVEL]
+                         compress archives with METHOD at LEVEL"))
   (display (G_ "
   -c, --cache=DIRECTORY  cache published items to DIRECTORY"))
   (display (G_ "
@@ -121,11 +122,14 @@ Publish ~a over HTTP.\n") %store-directory)
   ;; Since we compress on the fly, default to fast compression.
   (compression 'gzip 3))
 
-(define (actual-compression item requested)
-  "Return the actual compression used for ITEM, which may be %NO-COMPRESSION
+(define (default-compression type)
+  (compression type 3))
+
+(define (actual-compressions item requested)
+  "Return the actual compressions used for ITEM, which may be %NO-COMPRESSION
 if ITEM is already compressed."
   (if (compressed-file? item)
-      %no-compression
+      (list %no-compression)
       requested))
 
 (define %options
@@ -153,18 +157,28 @@ if ITEM is already compressed."
                             name)))))
         (option '(#\C "compression") #f #t
                 (lambda (opt name arg result)
-                  (match (if arg (string->number* arg) 3)
-                    (0
-                     (alist-cons 'compression %no-compression result))
-                    (level
-                     (if (zlib-available?)
-                         (alist-cons 'compression
-                                     (compression 'gzip level)
-                                     result)
-                         (begin
-                           (warning (G_ "zlib support is missing; \
-compression disabled~%"))
-                           result))))))
+                  (let* ((colon (string-index arg #\:))
+                         (type  (cond
+                                 (colon (string-take arg colon))
+                                 ((string->number arg) "gzip")
+                                 (else arg)))
+                         (level (if colon
+                                    (string->number*
+                                     (string-drop arg (+ 1 colon)))
+                                    (or (string->number arg) 3))))
+                    (match level
+                      (0
+                       (alist-cons 'compression %no-compression result))
+                      (level
+                       (match (string->compression-type type)
+                         ((? symbol? type)
+                          (alist-cons 'compression
+                                      (compression type level)
+                                      result))
+                         (_
+                          (warning (G_ "~a: unsupported compression type~%")
+                                   type)
+                          result)))))))
         (option '(#\c "cache") #t #f
                 (lambda (opt name arg result)
                   (alist-cons 'cache arg result)))
@@ -203,11 +217,6 @@ compression disabled~%"))
     (public-key-file . ,%public-key-file)
     (private-key-file . ,%private-key-file)
 
-    ;; Default to fast & low compression.
-    (compression . ,(if (zlib-available?)
-                        %default-gzip-compression
-                        %no-compression))
-
     ;; Default number of workers when caching is enabled.
     (workers . ,(current-processor-count))
 
@@ -235,29 +244,40 @@ compression disabled~%"))
 (define base64-encode-string
   (compose base64-encode string->utf8))
 
+(define* (store-item->recutils store-item
+                               #:key
+                               (nar-path "nar")
+                               (compression %no-compression)
+                               file-size)
+  "Return the 'Compression' and 'URL' fields of the narinfo for STORE-ITEM,
+with COMPRESSION, starting at NAR-PATH."
+  (let ((url (encode-and-join-uri-path
+              `(,@(split-and-decode-uri-path nar-path)
+                ,@(match compression
+                    (($ <compression> 'none)
+                     '())
+                    (($ <compression> type)
+                     (list (symbol->string type))))
+                ,(basename store-item)))))
+    (format #f "URL: ~a~%Compression: ~a~%~@[FileSize: ~a~%~]"
+            url (compression-type compression) file-size)))
+
 (define* (narinfo-string store store-path key
-                         #:key (compression %no-compression)
-                         (nar-path "nar") file-size)
+                         #:key (compressions (list %no-compression))
+                         (nar-path "nar") (file-sizes '()))
   "Generate a narinfo key/value string for STORE-PATH; an exception is raised
 if STORE-PATH is invalid.  Produce a URL that corresponds to COMPRESSION.  The
 narinfo is signed with KEY.  NAR-PATH specifies the prefix for nar URLs.
-Optionally, FILE-SIZE can specify the size in bytes of the compressed NAR; it
-informs the client of how much needs to be downloaded."
+
+Optionally, FILE-SIZES is a list of compression/integer pairs, where the
+integer is size in bytes of the compressed NAR; it informs the client of how
+much needs to be downloaded."
   (let* ((path-info  (query-path-info store store-path))
-         (compression (actual-compression store-path compression))
-         (url        (encode-and-join-uri-path
-                      `(,@(split-and-decode-uri-path nar-path)
-                        ,@(match compression
-                            (($ <compression> 'none)
-                             '())
-                            (($ <compression> type)
-                             (list (symbol->string type))))
-                        ,(basename store-path))))
+         (compressions (actual-compressions store-path compressions))
          (hash       (bytevector->nix-base32-string
                       (path-info-hash path-info)))
          (size       (path-info-nar-size path-info))
-         (file-size  (or file-size
-                         (and (eq? compression %no-compression) size)))
+         (file-sizes `((,%no-compression . ,size) ,@file-sizes))
          (references (string-join
                       (map basename (path-info-references path-info))
                       " "))
@@ -265,17 +285,21 @@ informs the client of how much needs to be downloaded."
          (base-info  (format #f
                              "\
 StorePath: ~a
-URL: ~a
-Compression: ~a
+~{~a~}\
 NarHash: sha256:~a
 NarSize: ~d
-References: ~a~%~a"
-                             store-path url
-                             (compression-type compression)
-                             hash size references
-                             (if file-size
-                                 (format #f "FileSize: ~a~%" file-size)
-                                 "")))
+References: ~a~%"
+                             store-path
+                             (map (lambda (compression)
+                                    (let ((size (assoc-ref file-sizes
+                                                           compression)))
+                                      (store-item->recutils store-path
+                                                            #:file-size size
+                                                            #:nar-path nar-path
+                                                            #:compression
+                                                            compression)))
+                                  compressions)
+                             hash size references))
          ;; Do not render a "Deriver" or "System" line if we are rendering
          ;; info for a derivation.
          (info       (if (not deriver)
@@ -318,7 +342,7 @@ References: ~a~%~a"
                       %nix-cache-info))))
 
 (define* (render-narinfo store request hash
-                         #:key ttl (compression %no-compression)
+                         #:key ttl (compressions (list %no-compression))
                          (nar-path "nar"))
   "Render metadata for the store path corresponding to HASH.  If TTL is true,
 advertise it as the maximum validity period (in seconds) via the
@@ -334,7 +358,7 @@ appropriate duration.  NAR-PATH specifies the prefix for nar URLs."
                 (cut display
                   (narinfo-string store store-path (%private-key)
                                   #:nar-path nar-path
-                                  #:compression compression)
+                                  #:compressions compressions)
                   <>)))))
 
 (define* (nar-cache-file directory item
@@ -350,6 +374,9 @@ appropriate duration.  NAR-PATH specifies the prefix for nar URLs."
                  "/" (basename item)
                  ".narinfo"))
 
+(define (hash-part-mapping-cache-file directory hash)
+  (string-append directory "/hashes/" hash))
+
 (define run-single-baker
   (let ((baking (make-weak-value-hash-table))
         (mutex  (make-mutex)))
@@ -403,8 +430,29 @@ items.  Failing that, we could eventually have to recompute them and return
             +inf.0
             (expiration-time file))))))
 
+(define (hash-part->path* store hash cache)
+  "Like 'hash-part->path' but cached results under CACHE.  This ensures we can
+still map HASH to the corresponding store file name, even if said store item
+vanished from the store in the meantime."
+  (let ((cached (hash-part-mapping-cache-file cache hash)))
+    (catch 'system-error
+      (lambda ()
+        (call-with-input-file cached read-string))
+      (lambda args
+        (if (= ENOENT (system-error-errno args))
+            (match (hash-part->path store hash)
+              ("" "")
+              (result
+               (mkdir-p (dirname cached))
+               (call-with-output-file (string-append cached ".tmp")
+                 (lambda (port)
+                   (display result port)))
+               (rename-file (string-append cached ".tmp") cached)
+               result))
+            (apply throw args))))))
+
 (define* (render-narinfo/cached store request hash
-                                #:key ttl (compression %no-compression)
+                                #:key ttl (compressions (list %no-compression))
                                 (nar-path "nar")
                                 cache pool)
   "Respond to the narinfo request for REQUEST.  If the narinfo is available in
@@ -412,17 +460,22 @@ CACHE, then send it; otherwise, return 404 and \"bake\" that nar and narinfo
 requested using POOL."
   (define (delete-entry narinfo)
     ;; Delete NARINFO and the corresponding nar from CACHE.
-    (let ((nar (string-append (string-drop-right narinfo
-                                                 (string-length ".narinfo"))
-                              ".nar")))
+    (let* ((nar     (string-append (string-drop-right narinfo
+                                                      (string-length ".narinfo"))
+                                   ".nar"))
+           (base    (basename narinfo ".narinfo"))
+           (hash    (string-take base (string-index base #\-)))
+           (mapping (hash-part-mapping-cache-file cache hash)))
       (delete-file* narinfo)
-      (delete-file* nar)))
-
-  (let* ((item        (hash-part->path store hash))
-         (compression (actual-compression item compression))
-         (cached      (and (not (string-null? item))
-                           (narinfo-cache-file cache item
-                                               #:compression compression))))
+      (delete-file* nar)
+      (delete-file* mapping)))
+
+  (let* ((item         (hash-part->path* store hash cache))
+         (compressions (actual-compressions item compressions))
+         (cached       (and (not (string-null? item))
+                            (narinfo-cache-file cache item
+                                                #:compression
+                                                (first compressions)))))
     (cond ((string-null? item)
            (not-found request))
           ((file-exists? cached)
@@ -446,7 +499,7 @@ requested using POOL."
                  ;; (format #t "baking ~s~%" item)
                  (bake-narinfo+nar cache item
                                    #:ttl ttl
-                                   #:compression compression
+                                   #:compressions compressions
                                    #:nar-path nar-path)))
 
              (when ttl
@@ -463,47 +516,75 @@ requested using POOL."
           (else
            (not-found request #:phrase "")))))
 
+(define (compress-nar cache item compression)
+  "Save in directory CACHE the nar for ITEM compressed with COMPRESSION."
+  (define nar
+    (nar-cache-file cache item #:compression compression))
+
+  (mkdir-p (dirname nar))
+  (match (compression-type compression)
+    ('gzip
+     ;; Note: the file port gets closed along with the gzip port.
+     (call-with-gzip-output-port (open-output-file (string-append nar ".tmp"))
+       (lambda (port)
+         (write-file item port))
+       #:level (compression-level compression)
+       #:buffer-size (* 128 1024))
+     (rename-file (string-append nar ".tmp") nar))
+    ('lzip
+     ;; Note: the file port gets closed along with the lzip port.
+     (call-with-lzip-output-port (open-output-file (string-append nar ".tmp"))
+       (lambda (port)
+         (write-file item port))
+       #:level (compression-level compression))
+     (rename-file (string-append nar ".tmp") nar))
+    ('none
+     ;; Cache nars even when compression is disabled so that we can
+     ;; guarantee the TTL (see <https://bugs.gnu.org/28664>.)
+     (with-atomic-file-output nar
+       (lambda (port)
+         (write-file item port))))))
+
 (define* (bake-narinfo+nar cache item
-                           #:key ttl (compression %no-compression)
+                           #:key ttl (compressions (list %no-compression))
                            (nar-path "/nar"))
   "Write the narinfo and nar for ITEM to CACHE."
-  (let* ((compression (actual-compression item compression))
-         (nar         (nar-cache-file cache item
-                                      #:compression compression))
-         (narinfo     (narinfo-cache-file cache item
-                                          #:compression compression)))
-
-    (mkdir-p (dirname nar))
-    (match (compression-type compression)
-      ('gzip
-       ;; Note: the file port gets closed along with the gzip port.
-       (call-with-gzip-output-port (open-output-file (string-append nar ".tmp"))
-         (lambda (port)
-           (write-file item port))
-         #:level (compression-level compression)
-         #:buffer-size (* 128 1024))
-       (rename-file (string-append nar ".tmp") nar))
-      ('none
-       ;; Cache nars even when compression is disabled so that we can
-       ;; guarantee the TTL (see <https://bugs.gnu.org/28664>.)
-       (with-atomic-file-output nar
-         (lambda (port)
-           (write-file item port)))))
-
-    (mkdir-p (dirname narinfo))
-    (with-atomic-file-output narinfo
-      (lambda (port)
-        ;; Open a new connection to the store.  We cannot reuse the main
-        ;; thread's connection to the store since we would end up sending
-        ;; stuff concurrently on the same channel.
-        (with-store store
-          (display (narinfo-string store item
-                                   (%private-key)
-                                   #:nar-path nar-path
-                                   #:compression compression
-                                   #:file-size (and=> (stat nar #f)
-                                                      stat:size))
-                   port))))))
+  (define (compressed-nar-size compression)
+    (let* ((nar  (nar-cache-file cache item #:compression compression))
+           (stat (stat nar #f)))
+      (and stat
+           (cons compression (stat:size stat)))))
+
+  (let ((compression (actual-compressions item compressions)))
+
+    (for-each (cut compress-nar cache item <>) compressions)
+
+    (match compressions
+      ((main others ...)
+       (let ((narinfo (narinfo-cache-file cache item
+                                          #:compression main)))
+         (with-atomic-file-output narinfo
+           (lambda (port)
+             ;; Open a new connection to the store.  We cannot reuse the main
+             ;; thread's connection to the store since we would end up sending
+             ;; stuff concurrently on the same channel.
+             (with-store store
+               (let ((sizes (filter-map compressed-nar-size compression)))
+                 (display (narinfo-string store item
+                                          (%private-key)
+                                          #:nar-path nar-path
+                                          #:compressions compressions
+                                          #:file-sizes sizes)
+                          port)))))
+
+         ;; Make narinfo files for OTHERS hard links to NARINFO such that the
+         ;; atime-based cache eviction considers either all the nars or none
+         ;; of them as candidates.
+         (for-each (lambda (other)
+                     (let ((other (narinfo-cache-file cache item
+                                                      #:compression other)))
+                       (link narinfo other)))
+                   others))))))
 
 ;; XXX: Declare the 'X-Nar-Compression' HTTP header, which is in fact for
 ;; internal consumption: it allows us to pass the compression info to
@@ -687,6 +768,9 @@ example: \"/foo/bar\" yields '(\"foo\" \"bar\")."
      (make-gzip-output-port (response-port response)
                             #:level level
                             #:buffer-size (* 64 1024)))
+    (($ <compression> 'lzip level)
+     (make-lzip-output-port (response-port response)
+                            #:level level))
     (($ <compression> 'none)
      (response-port response))
     (#f
@@ -761,12 +845,33 @@ blocking."
   http-write
   (@@ (web server http) http-close))
 
+(define (string->compression-type string)
+  "Return a symbol denoting the compression method expressed by STRING; return
+#f if STRING doesn't match any supported method."
+  (match string
+    ("gzip" (and (zlib-available?) 'gzip))
+    ("lzip" (and (lzlib-available?) 'lzip))
+    (_      #f)))
+
+(define (effective-compression requested-type compressions)
+  "Given the REQUESTED-TYPE for compression and the set of chosen COMPRESSION
+methods, return the applicable compression."
+  (or (find (match-lambda
+              (($ <compression> type)
+               (and (eq? type requested-type)
+                    compression)))
+            compressions)
+      (default-compression requested-type)))
+
 (define* (make-request-handler store
                                #:key
                                cache pool
                                narinfo-ttl
                                (nar-path "nar")
-                               (compression %no-compression))
+                               (compressions (list %no-compression)))
+  (define compression-type?
+    string->compression-type)
+
   (define nar-path?
     (let ((expected (split-and-decode-uri-path nar-path)))
       (cut equal? expected <>)))
@@ -785,19 +890,17 @@ blocking."
            (render-home-page request))
           ;; /<hash>.narinfo
           (((= extract-narinfo-hash (? string? hash)))
-           ;; TODO: Register roots for HASH that will somehow remain for
-           ;; NARINFO-TTL.
            (if cache
                (render-narinfo/cached store request hash
                                       #:cache cache
                                       #:pool pool
                                       #:ttl narinfo-ttl
                                       #:nar-path nar-path
-                                      #:compression compression)
+                                      #:compressions compressions)
                (render-narinfo store request hash
                                #:ttl narinfo-ttl
                                #:nar-path nar-path
-                               #:compression compression)))
+                               #:compressions compressions)))
           ;; /nar/file/NAME/sha256/HASH
           (("file" name "sha256" hash)
            (guard (c ((invalid-base32-character? c)
@@ -815,13 +918,11 @@ blocking."
           ;; is restarted with different compression parameters.
 
           ;; /nar/gzip/<store-item>
-          ((components ... "gzip" store-item)
-           (if (and (nar-path? components) (zlib-available?))
-               (let ((compression (match compression
-                                    (($ <compression> 'gzip)
-                                     compression)
-                                    (_
-                                     %default-gzip-compression))))
+          ((components ... (? compression-type? type) store-item)
+           (if (nar-path? components)
+               (let* ((compression-type (string->compression-type type))
+                      (compression (effective-compression compression-type
+                                                          compressions)))
                  (if cache
                      (render-nar/cached store cache request store-item
                                         #:ttl narinfo-ttl
@@ -845,7 +946,8 @@ blocking."
         (not-found request))))
 
 (define* (run-publish-server socket store
-                             #:key (compression %no-compression)
+                             #:key
+                             (compressions (list %no-compression))
                              (nar-path "nar") narinfo-ttl
                              cache pool)
   (run-server (make-request-handler store
@@ -853,7 +955,7 @@ blocking."
                                     #:pool pool
                                     #:nar-path nar-path
                                     #:narinfo-ttl narinfo-ttl
-                                    #:compression compression)
+                                    #:compressions compressions)
               concurrent-http-server
               `(#:socket ,socket)))
 
@@ -892,7 +994,17 @@ blocking."
            (user    (assoc-ref opts 'user))
            (port    (assoc-ref opts 'port))
            (ttl     (assoc-ref opts 'narinfo-ttl))
-           (compression (assoc-ref opts 'compression))
+           (compressions (match (filter-map (match-lambda
+                                              (('compression . compression)
+                                               compression)
+                                              (_ #f))
+                                            opts)
+                           (()
+                            ;; Default to fast & low compression.
+                            (list (if (zlib-available?)
+                                      %default-gzip-compression
+                                      %no-compression)))
+                           (lst (reverse lst))))
            (address (let ((addr (assoc-ref opts 'address)))
                       (make-socket-address (sockaddr:fam addr)
                                            (sockaddr:addr addr)
@@ -919,10 +1031,17 @@ consider using the '--user' option!~%")))
 
       (parameterize ((%public-key public-key)
                      (%private-key private-key))
-        (format #t (G_ "publishing ~a on ~a, port ~d~%")
-                %store-directory
-                (inet-ntop (sockaddr:fam address) (sockaddr:addr address))
-                (sockaddr:port address))
+        (info (G_ "publishing ~a on ~a, port ~d~%")
+              %store-directory
+              (inet-ntop (sockaddr:fam address) (sockaddr:addr address))
+              (sockaddr:port address))
+
+        (for-each (lambda (compression)
+                    (info (G_ "using '~a' compression method, level ~a~%")
+                          (compression-type compression)
+                          (compression-level compression)))
+                  compressions)
+
         (when repl-port
           (repl:spawn-server (repl:make-tcp-server-socket #:port repl-port)))
 
@@ -936,7 +1055,7 @@ consider using the '--user' option!~%")))
                                                            #:thread-name
                                                            "publish worker"))
                               #:nar-path nar-path
-                              #:compression compression
+                              #:compressions compressions
                               #:narinfo-ttl ttl))))))
 
 ;;; Local Variables:
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)~%")