05/06: weather: Add '--coverage'.

[guix-commits]

civodul pushed a commit to branch master
in repository guix.

commit bd414e273c2010132895a645b623035c218eb437
Author: Ludovic Courtès <address@hidden>
Date:   Fri Jan 25 13:57:38 2019 +0100

    weather: Add '--coverage'.
    
    * guix/scripts/weather.scm (show-help, %options): Add '--coverage'.
    (package-partition-boundary, package->output-mapping)
    (substitute-oracle, report-package-coverage-per-system)
    (report-package-coverage): New procedures.
    (guix-weather): Honor '--coverage'.
    * doc/guix.texi (Invoking guix weather): Document it.
---
 doc/guix.texi            |  35 +++++++++-
 guix/scripts/weather.scm | 167 ++++++++++++++++++++++++++++++++++++++++++++++-
 2 files changed, 200 insertions(+), 2 deletions(-)

diff --git a/doc/guix.texi b/doc/guix.texi
index afc0ef8..a182e1e 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -9709,7 +9709,9 @@ key is authorized.  It also reports the size of the 
compressed archives
 (``nars'') provided by the server, the size the corresponding store
 items occupy in the store (assuming deduplication is turned off), and
 the server's throughput.  The second part gives continuous integration
-(CI) statistics, if the server supports it.
+(CI) statistics, if the server supports it.  In addition, using the
address@hidden option, @command{guix weather} can list ``important''
+package substitutes missing on the server (see below).
 
 To achieve that, @command{guix weather} queries over HTTP(S) meta-data
 (@dfn{narinfos}) for all the relevant store items.  Like @command{guix
@@ -9737,6 +9739,37 @@ Instead of querying substitutes for all the packages, 
only ask for those
 specified in @var{file}.  @var{file} must contain a @dfn{manifest}, as
 with the @code{-m} option of @command{guix package} (@pxref{Invoking
 guix package}).
+
address@hidden address@hidden
address@hidden -c address@hidden
+Report on substitute coverage for packages: list packages with at least
address@hidden dependents (zero by default) for which substitutes are
+unavailable.  Dependent packages themselves are not listed: if @var{b} depends
+on @var{a} and @var{a} has no substitutes, only @var{a} is listed, even though
address@hidden usually lacks substitutes as well.  The result looks like this:
+
address@hidden
+$ guix weather --substitute-urls=https://ci.guix.info -c 10
+computing 8,983 package derivations for x86_64-linux...
+looking for 9,343 store items on https://ci.guix.info...
+updating substitutes from 'https://ci.guix.info'... 100.0%
+https://ci.guix.info
+  64.7% substitutes available (6,047 out of 9,343)
address@hidden
+2502 packages are missing from 'https://ci.guix.info' for 'x86_64-linux', 
among which:
+    58  kcoreaddons@@5.49.0      /gnu/store/@dots{}-kcoreaddons-5.49.0
+    46  qgpgme@@1.11.1           /gnu/store/@dots{}-qgpgme-1.11.1
+    37  perl-http-cookiejar@@0.008  
/gnu/store/@dots{}-perl-http-cookiejar-0.008
+    @dots{}
address@hidden example
+
+What this example shows is that @code{kcoreaddons} and presumably the 58
+packages that depend on it have no substitutes at @code{ci.guix.info};
+likewise for @code{qgpgme} and the 46 packages that depend on it.
+
+If you are a Guix developer, or if you are taking care of this build farm,
+you'll probably want to have a closer look at these packages: they may simply
+fail to build.
 @end table
 
 @node Invoking guix processes
diff --git a/guix/scripts/weather.scm b/guix/scripts/weather.scm
index bb326a6..4b12f95 100644
--- a/guix/scripts/weather.scm
+++ b/guix/scripts/weather.scm
@@ -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)
@@ -257,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_ "
@@ -289,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)))))
@@ -305,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 "  address@hidden ~}~%"
+                              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.
 ;;;
 
@@ -334,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: