diff options
| -rw-r--r-- | doc/guix.texi | 35 | ||||
| -rw-r--r-- | guix/scripts/weather.scm | 167 |
2 files changed, 200 insertions, 2 deletions
diff --git a/doc/guix.texi b/doc/guix.texi index afc0ef8615..a182e1edee 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 +@option{--coverage} 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}). + +@item --coverage[=@var{count}] +@itemx -c [@var{count}] +Report on substitute coverage for packages: list packages with at least +@var{count} 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 +@var{b} usually lacks substitutes as well. The result looks like this: + +@example +$ 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) +@dots{} +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{} +@end 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 bb326a651a..4b12f9550e 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 " ~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. ;;; @@ -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: |