Merge branch 'master' into staging

8 files changed, 251 insertions, 49 deletions

diff --git a/guix/licenses.scm b/guix/licenses.scm
index 4ef18fb326..4ef3ed188c 100644
--- a/guix/licenses.scm
+++ b/guix/licenses.scm
@@ -3,7 +3,7 @@
 ;;; Copyright © 2013, 2015 Andreas Enge <andreas@enge.fr>
 ;;; Copyright © 2012, 2013 Nikita Karetnikov <nikita@karetnikov.org>
 ;;; Copyright © 2015 Mark H Weaver <mhw@netris.org>
-;;; Copyright © 2015 Ricardo Wurmus <rekado@elephly.net>
+;;; Copyright © 2015, 2019 Ricardo Wurmus <rekado@elephly.net>
 ;;; Copyright © 2016 Eric Bavier <bavier@member.fsf.org>
 ;;; Copyright © 2016 Leo Famulari <leo@famulari.name>
 ;;; Copyright © 2016 Fabian Harfert <fhmgufs@web.de>
@@ -65,7 +65,7 @@
             ipa
             knuth
             lgpl2.0 lgpl2.0+ lgpl2.1 lgpl2.1+ lgpl3 lgpl3+
-            lppl lppl1.0+ lppl1.2 lppl1.2+
+            lppl lppl1.0+ lppl1.1+ lppl1.2 lppl1.2+
             lppl1.3 lppl1.3+
             lppl1.3a lppl1.3a+
             lppl1.3b lppl1.3b+
@@ -421,6 +421,11 @@ at URI, which may be a file:// URI pointing the package's tree."
            "https://www.latex-project.org/lppl/lppl-1-0/"
            "LaTeX Project Public License 1.0"))
 
+(define lppl1.1+
+  (license "LPPL 1.1+"
+           "https://www.latex-project.org/lppl/lppl-1-1/"
+           "LaTeX Project Public License 1.1"))
+
 (define lppl1.2
   (license "LPPL 1.2"
            "http://directory.fsf.org/wiki/License:LPPLv1.2"
diff --git a/guix/packages.scm b/guix/packages.scm
index e4c2ac3be5..f191327718 100644
--- a/guix/packages.scm
+++ b/guix/packages.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2014, 2015, 2017, 2018 Mark H Weaver <mhw@netris.org>
 ;;; Copyright © 2015 Eric Bavier <bavier@member.fsf.org>
 ;;; Copyright © 2016 Alex Kost <alezost@gmail.com>
@@ -133,6 +133,7 @@
             bag-transitive-host-inputs
             bag-transitive-build-inputs
             bag-transitive-target-inputs
+            package-closure
 
             default-guile
             default-guile-derivation
@@ -798,6 +799,28 @@ dependencies are known to build on SYSTEM."
   "Return the \"target inputs\" of BAG, recursively."
   (transitive-inputs (bag-target-inputs bag)))
 
+(define* (package-closure packages #:key (system (%current-system)))
+  "Return the closure of PACKAGES on SYSTEM--i.e., PACKAGES and the list of
+packages they depend on, recursively."
+  (let loop ((packages packages)
+             (visited  vlist-null)
+             (closure  (list->setq packages)))
+    (match packages
+      (()
+       (set->list closure))
+      ((package . rest)
+       (if (vhash-assq package visited)
+           (loop rest visited closure)
+           (let* ((bag          (package->bag package system))
+                  (dependencies (filter-map (match-lambda
+                                              ((label (? package? package) . _)
+                                               package)
+                                              (_ #f))
+                                            (bag-direct-inputs bag))))
+             (loop (append dependencies rest)
+                   (vhash-consq package #t visited)
+                   (fold set-insert closure dependencies))))))))
+
 (define* (package-mapping proc #:optional (cut? (const #f)))
   "Return a procedure that, given a package, applies PROC to all the packages
 depended on and returns the resulting package.  The procedure stops recursion
diff --git a/guix/records.scm b/guix/records.scm
index 6b3c25cefa..0649c90ea3 100644
--- a/guix/records.scm
+++ b/guix/records.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2018 Mark H Weaver <mhw@netris.org>
 ;;;
 ;;; This file is part of GNU Guix.
@@ -44,31 +44,6 @@
                        (format #f fmt args ...)
                        form))))
 
-(define (report-invalid-field-specifier name bindings)
-  "Report the first invalid binding among BINDINGS."
-  (let loop ((bindings bindings))
-    (syntax-case bindings ()
-      (((field value) rest ...)                   ;good
-       (loop #'(rest ...)))
-      ((weird _ ...)                              ;weird!
-       (syntax-violation name "invalid field specifier" #'weird)))))
-
-(define (report-duplicate-field-specifier name ctor)
-  "Report the first duplicate identifier among the bindings in CTOR."
-  (syntax-case ctor ()
-    ((_ bindings ...)
-     (let loop ((bindings #'(bindings ...))
-                (seen   '()))
-       (syntax-case bindings ()
-         (((field value) rest ...)
-          (not (memq (syntax->datum #'field) seen))
-          (loop #'(rest ...) (cons (syntax->datum #'field) seen)))
-         ((duplicate rest ...)
-          (syntax-violation name "duplicate field initializer"
-                            #'duplicate))
-         (()
-          #t))))))
-
 (eval-when (expand load eval)
   ;; The procedures below are needed both at run time and at expansion time.
 
@@ -91,7 +66,32 @@ interface\" (ABI) for TYPE is equal to COOKIE."
           ;; recompiled.
           (throw 'record-abi-mismatch-error 'abi-check
                  "~a: record ABI mismatch; recompilation needed"
-                 (list #,type) '())))))
+                 (list #,type) '()))))
+
+  (define (report-invalid-field-specifier name bindings)
+    "Report the first invalid binding among BINDINGS."
+    (let loop ((bindings bindings))
+      (syntax-case bindings ()
+        (((field value) rest ...)                   ;good
+         (loop #'(rest ...)))
+        ((weird _ ...)                              ;weird!
+         (syntax-violation name "invalid field specifier" #'weird)))))
+
+  (define (report-duplicate-field-specifier name ctor)
+    "Report the first duplicate identifier among the bindings in CTOR."
+    (syntax-case ctor ()
+      ((_ bindings ...)
+       (let loop ((bindings #'(bindings ...))
+                  (seen   '()))
+         (syntax-case bindings ()
+           (((field value) rest ...)
+            (not (memq (syntax->datum #'field) seen))
+            (loop #'(rest ...) (cons (syntax->datum #'field) seen)))
+           ((duplicate rest ...)
+            (syntax-violation name "duplicate field initializer"
+                              #'duplicate))
+           (()
+            #t)))))))
 
 (define-syntax make-syntactic-constructor
   (syntax-rules ()
diff --git a/guix/scripts/refresh.scm b/guix/scripts/refresh.scm
index a0de9f6c10..5b0f345cde 100644
--- a/guix/scripts/refresh.scm
+++ b/guix/scripts/refresh.scm
@@ -400,7 +400,7 @@ the latest known version of ~a (~a)~%")
                    (package-version package)))
 
   (mlet %store-monad ((edges (node-back-edges %bag-node-type
-                                              (all-packages))))
+                                              (package-closure (all-packages)))))
     (let* ((dependents (node-transitive-edges packages edges))
            (covering   (filter (lambda (node)
                                  (null? (edges node)))
@@ -419,8 +419,8 @@ the latest known version of ~a (~a)~%")
                  (full-name x)))
         (lst
          (format (current-output-port)
-                 (N_ "Building the following package would ensure ~d \
-dependent packages are rebuilt: ~*~{~a~^ ~}~%"
+                 (N_ "Building the following ~*package would ensure ~d \
+dependent packages are rebuilt: ~{~a~^ ~}~%"
                      "Building the following ~d packages would ensure ~d \
 dependent packages are rebuilt: ~{~a~^ ~}~%"
                      (length covering))
diff --git a/guix/scripts/weather.scm b/guix/scripts/weather.scm
index 98b7338fb9..4b12f9550e 100644
--- a/guix/scripts/weather.scm
+++ b/guix/scripts/weather.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2017, 2018 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2017 Ricardo Wurmus <rekado@elephly.net>
 ;;; Copyright © 2018 Kyle Meyer <kyle@kyleam.com>
 ;;;
@@ -32,6 +32,9 @@
   #:use-module (guix scripts substitute)
   #:use-module (guix http-client)
   #:use-module (guix ci)
+  #:use-module (guix sets)
+  #:use-module (guix graph)
+  #:autoload   (guix scripts graph) (%bag-node-type)
   #:use-module (gnu packages)
   #:use-module (web uri)
   #:use-module (srfi srfi-1)
@@ -41,6 +44,7 @@
   #:use-module (srfi srfi-37)
   #:use-module (ice-9 match)
   #:use-module (ice-9 format)
+  #:use-module (ice-9 vlist)
   #:export (guix-weather))
 
 (define (all-packages)
@@ -51,7 +55,10 @@
                       (cons* replacement package result))
                      (#f
                       (cons package result))))
-                 '()))
+                 '()
+
+                 ;; Dismiss deprecated packages but keep hidden packages.
+                 #:select? (negate package-superseded)))
 
 (define (call-with-progress-reporter reporter proc)
   "This is a variant of 'call-with-progress-reporter' that works with monadic
@@ -254,6 +261,10 @@ Report the availability of substitutes.\n"))
   -m, --manifest=MANIFEST
                          look up substitutes for packages specified in MANIFEST"))
   (display (G_ "
+  -c, --coverage[=COUNT]
+                         show substitute coverage for packages with at least
+                         COUNT dependents"))
+  (display (G_ "
   -s, --system=SYSTEM    consider substitutes for SYSTEM--e.g., \"i686-linux\""))
   (newline)
   (display (G_ "
@@ -286,6 +297,11 @@ Report the availability of substitutes.\n"))
          (option '(#\m "manifest") #t #f
                  (lambda (opt name arg result)
                    (alist-cons 'manifest arg result)))
+         (option '(#\c "coverage") #f #t
+                 (lambda (opt name arg result)
+                   (alist-cons 'coverage
+                               (if arg (string->number* arg) 0)
+                               result)))
          (option '(#\s "system") #t #f
                  (lambda (opt name arg result)
                    (alist-cons 'system arg result)))))
@@ -302,6 +318,153 @@ Report the availability of substitutes.\n"))
 
 
 ;;;
+;;; Missing package substitutes.
+;;;
+
+(define* (package-partition-boundary pred packages
+                                     #:key (system (%current-system)))
+  "Return the subset of PACKAGES that are at the \"boundary\" between those
+that match PRED and those that don't.  The returned packages themselves do not
+match PRED but they have at least one direct dependency that does.
+
+Note: The assumption is that, if P matches PRED, then all the dependencies of
+P match PRED as well."
+  ;; XXX: Graph theoreticians surely have something to teach us about this...
+  (let loop ((packages packages)
+             (result (setq))
+             (visited vlist-null))
+    (define (visited? package)
+      (vhash-assq package visited))
+
+    (match packages
+      ((package . rest)
+       (cond ((visited? package)
+              (loop rest result visited))
+             ((pred package)
+              (loop rest result (vhash-consq package #t visited)))
+             (else
+              (let* ((bag  (package->bag package system))
+                     (deps (filter-map (match-lambda
+                                         ((label (? package? package) . _)
+                                          (and (not (pred package))
+                                               package))
+                                         (_ #f))
+                                       (bag-direct-inputs bag))))
+                (loop (append deps rest)
+                      (if (null? deps)
+                          (set-insert package result)
+                          result)
+                      (vhash-consq package #t visited))))))
+      (()
+       (set->list result)))))
+
+(define (package->output-mapping packages system)
+  "Return a vhash that maps each item of PACKAGES to its corresponding output
+store file names for SYSTEM."
+  (foldm %store-monad
+         (lambda (package mapping)
+           (mlet %store-monad ((drv (package->derivation package system
+                                                         #:graft? #f)))
+             (return (vhash-consq package
+                                  (match (derivation->output-paths drv)
+                                    (((names . outputs) ...)
+                                     outputs))
+                                  mapping))))
+         vlist-null
+         packages))
+
+(define (substitute-oracle server items)
+  "Return a procedure that, when passed a store item (one of those listed in
+ITEMS), returns true if SERVER has a substitute for it, false otherwise."
+  (define available
+    (fold (lambda (narinfo set)
+            (set-insert (narinfo-path narinfo) set))
+          (set)
+          (lookup-narinfos server items)))
+
+  (cut set-contains? available <>))
+
+(define* (report-package-coverage-per-system server packages system
+                                             #:key (threshold 0))
+  "Report on the subset of PACKAGES that lacks SYSTEM substitutes on SERVER,
+sorted by decreasing number of dependents.  Do not display those with less
+than THRESHOLD dependents."
+  (mlet* %store-monad ((packages -> (package-closure packages #:system system))
+                       (mapping    (package->output-mapping packages system))
+                       (back-edges (node-back-edges %bag-node-type packages)))
+    (define items
+      (vhash-fold (lambda (package items result)
+                    (append items result))
+                  '()
+                  mapping))
+
+    (define substitutable?
+      (substitute-oracle server items))
+
+    (define substitutable-package?
+      (lambda (package)
+        (match (vhash-assq package mapping)
+          ((_ . items)
+           (find substitutable? items))
+          (#f
+           #f))))
+
+    (define missing
+      (package-partition-boundary substitutable-package? packages
+                                  #:system system))
+
+    (define missing-count
+      (length missing))
+
+    (if (zero? threshold)
+        (format #t (N_ "The following ~a package is missing from '~a' for \
+'~a':~%"
+                       "The following ~a packages are missing from '~a' for \
+'~a':~%"
+                       missing-count)
+                missing-count server system)
+        (format #t (N_ "~a package is missing from '~a' for '~a':~%"
+                       "~a packages are missing from '~a' for '~a', among \
+which:~%"
+                       missing-count)
+                missing-count server system))
+
+    (for-each (match-lambda
+                ((package count)
+                 (match (vhash-assq package mapping)
+                   ((_ . items)
+                    (when (>= count threshold)
+                      (format #t "  ~4d\t~a@~a\t~{~a ~}~%"
+                              count
+                              (package-name package) (package-version package)
+                              items)))
+                   (#f                      ;PACKAGE must be an internal thing
+                    #f))))
+              (sort (zip missing
+                         (map (lambda (package)
+                                (node-reachable-count (list package)
+                                                      back-edges))
+                              missing))
+                    (match-lambda*
+                      (((_ count1) (_ count2))
+                       (< count2 count1)))))
+    (return #t)))
+
+(define* (report-package-coverage server packages systems
+                                  #:key (threshold 0))
+  "Report on the substitute coverage for PACKAGES, for each of SYSTEMS, on
+SERVER.  Display information for packages with at least THRESHOLD dependents."
+  (with-store store
+    (run-with-store store
+      (foldm %store-monad
+             (lambda (system _)
+               (report-package-coverage-per-system server packages system
+                                                   #:threshold threshold))
+             #f
+             systems))))
+
+
+;;;
 ;;; Entry point.
 ;;;
 
@@ -331,7 +494,12 @@ Report the availability of substitutes.\n"))
                                       (package-outputs packages system))
                                     systems)))))))
         (for-each (lambda (server)
-                    (report-server-coverage server items))
+                    (report-server-coverage server items)
+                    (match (assoc-ref opts 'coverage)
+                      (#f #f)
+                      (threshold
+                       (report-package-coverage server packages systems
+                                                #:threshold threshold))))
                   urls)))))
 
 ;;; Local Variables:
diff --git a/guix/store/deduplication.scm b/guix/store/deduplication.scm
index a777940f86..8ca16a4cd8 100644
--- a/guix/store/deduplication.scm
+++ b/guix/store/deduplication.scm
@@ -1,6 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2017 Caleb Ristvedt <caleb.ristvedt@cune.org>
-;;; Copyright © 2018 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2018, 2019 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -109,8 +109,9 @@ Note: TARGET, TO-REPLACE, and SWAP-DIRECTORY must be on the same file system."
         (get-temp-link target swap-directory))
       (lambda args
         ;; We get ENOSPC when we can't fit an additional entry in
-        ;; SWAP-DIRECTORY.
-        (if (= ENOSPC (system-error-errno args))
+        ;; SWAP-DIRECTORY.  If it's EMLINK, then TARGET has reached its
+        ;; maximum number of links.
+        (if (memv (system-error-errno args) `(,ENOSPC ,EMLINK))
             #f
             (apply throw args)))))
 
@@ -169,4 +170,8 @@ under STORE."
                          ;; more entries in .links, but that's fine: we can
                          ;; just stop.
                          #f)
+                        ((= errno EMLINK)
+                         ;; PATH has reached the maximum number of links, but
+                         ;; that's OK: we just can't deduplicate it more.
+                         #f)
                         (else (apply throw args))))))))))
diff --git a/guix/tests.scm b/guix/tests.scm
index 16a426c4f9..749a4edd7a 100644
--- a/guix/tests.scm
+++ b/guix/tests.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -334,18 +334,19 @@ CONTENTS."
 (define-syntax-rule (dummy-package name* extra-fields ...)
   "Return a \"dummy\" package called NAME*, with all its compulsory fields
 initialized with default values, and with EXTRA-FIELDS set as specified."
-  (package extra-fields ...
-           (name name*) (version "0") (source #f)
-           (build-system gnu-build-system)
-           (synopsis #f) (description #f)
-           (home-page #f) (license #f)))
+  (let ((p (package
+             (name name*) (version "0") (source #f)
+             (build-system gnu-build-system)
+             (synopsis #f) (description #f)
+             (home-page #f) (license #f))))
+    (package (inherit p) extra-fields ...)))
 
 (define-syntax-rule (dummy-origin extra-fields ...)
   "Return a \"dummy\" origin, with all its compulsory fields initialized with
 default values, and with EXTRA-FIELDS set as specified."
-  (origin extra-fields ...
-          (method #f) (uri "http://www.example.com")
-          (sha256 (base32 (make-string 52 #\x)))))
+  (let ((o (origin (method #f) (uri "http://www.example.com")
+                   (sha256 (base32 (make-string 52 #\x))))))
+    (origin (inherit o) extra-fields ...)))
 
 ;; Local Variables:
 ;; eval: (put 'call-with-derivation-narinfo 'scheme-indent-function 1)
diff --git a/guix/ui.scm b/guix/ui.scm
index 9ff56ea85c..9eab4ba3f7 100644
--- a/guix/ui.scm
+++ b/guix/ui.scm
@@ -690,7 +690,7 @@ or remove one of them from the profile.")
                     (strerror (store-connection-error-code c))))
             ((store-protocol-error? c)
              ;; FIXME: Server-provided error messages aren't i18n'd.
-             (leave (G_ "build failed: ~a~%")
+             (leave (G_ "~a~%")
                     (store-protocol-error-message c)))
             ((derivation-missing-output-error? c)
              (leave (G_ "reference to invalid output '~a' of derivation '~a'~%")