guix/scripts/weather.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
   3 ;;; Copyright © 2017 Ricardo Wurmus <rekado@elephly.net>
   4 ;;; Copyright © 2018 Kyle Meyer <kyle@kyleam.com>
   5 ;;;
   6 ;;; This file is part of GNU Guix.
   7 ;;;
   8 ;;; GNU Guix is free software; you can redistribute it and/or modify it
   9 ;;; under the terms of the GNU General Public License as published by
  10 ;;; the Free Software Foundation; either version 3 of the License, or (at
  11 ;;; your option) any later version.
  12 ;;;
  13 ;;; GNU Guix is distributed in the hope that it will be useful, but
  14 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  15 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  16 ;;; GNU General Public License for more details.
  17 ;;;
  18 ;;; You should have received a copy of the GNU General Public License
  19 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  20
  21 (define-module (guix scripts weather)
  22   #:use-module (guix ui)
  23   #:use-module (guix scripts)
  24   #:use-module (guix packages)
  25   #:use-module (guix profiles)
  26   #:use-module (guix derivations)
  27   #:use-module (guix progress)
  28   #:use-module (guix monads)
  29   #:use-module (guix store)
  30   #:use-module (guix grafts)
  31   #:use-module (guix gexp)
  32   #:use-module ((guix build syscalls) #:select (terminal-columns))
  33   #:use-module (guix scripts substitute)
  34   #:use-module (guix http-client)
  35   #:use-module (guix ci)
  36   #:use-module (guix sets)
  37   #:use-module (guix graph)
  38   #:autoload   (guix scripts graph) (%bag-node-type)
  39   #:use-module (gnu packages)
  40   #:use-module (web uri)
  41   #:use-module (srfi srfi-1)
  42   #:use-module (srfi srfi-19)
  43   #:use-module (srfi srfi-26)
  44   #:use-module (srfi srfi-34)
  45   #:use-module (srfi srfi-37)
  46   #:use-module (ice-9 match)
  47   #:use-module (ice-9 format)
  48   #:use-module (ice-9 vlist)
  49   #:export (guix-weather))
  50
  51 (define (all-packages)
  52   "Return the list of public packages we are going to query."
  53   (fold-packages (lambda (package result)
  54                    (match (package-replacement package)
  55                      ((? package? replacement)
  56                       (cons* replacement package result))
  57                      (#f
  58                       (cons package result))))
  59                  '()
  60
  61                  ;; Dismiss deprecated packages but keep hidden packages.
  62                  #:select? (negate package-superseded)))
  63
  64 (define (call-with-progress-reporter reporter proc)
  65   "This is a variant of 'call-with-progress-reporter' that works with monadic
  66 scope."
  67   ;; TODO: Move to a more appropriate place.
  68   (with-monad %store-monad
  69     (start-progress-reporter! reporter)
  70     (mlet* %store-monad ((report -> (lambda ()
  71                                       (progress-reporter-report! reporter)))
  72                          (result (proc report)))
  73       (stop-progress-reporter! reporter)
  74       (return result))))
  75
  76 (define* (package-outputs packages
  77                           #:optional (system (%current-system)))
  78   "Return the list of outputs of all of PACKAGES for the given SYSTEM."
  79   (define (lower-object/no-grafts obj system)
  80     (mlet* %store-monad ((previous (set-grafting #f))
  81                          (drv      (lower-object obj system))
  82                          (_        (set-grafting previous)))
  83       (return drv)))
  84
  85   (let ((packages (filter (lambda (package)
  86                             (or (not (package? package))
  87                                 (supported-package? package system)))
  88                           packages)))
  89     (format (current-error-port)
  90             (G_ "computing ~h package derivations for ~a...~%")
  91             (length packages) system)
  92
  93     (call-with-progress-reporter (progress-reporter/bar (length packages))
  94       (lambda (report)
  95         (foldm %store-monad
  96                (lambda (package result)
  97                  ;; PACKAGE could in fact be a non-package object, for example
  98                  ;; coming from a user-specified manifest.  Thus, use
  99                  ;; 'lower-object' rather than 'package->derivation' here.
 100                  (mlet %store-monad ((drv (lower-object/no-grafts package
 101                                                                   system)))
 102                    (report)
 103                    (match (derivation->output-paths drv)
 104                      (((names . items) ...)
 105                       (return (append items result))))))
 106                '()
 107                packages)))))
 108
 109 (define (call-with-time thunk kont)
 110   "Call THUNK and pass KONT the elapsed time followed by THUNK's return
 111 values."
 112   (let* ((start  (current-time time-monotonic))
 113          (result (call-with-values thunk list))
 114          (end    (current-time time-monotonic)))
 115     (apply kont (time-difference end start) result)))
 116
 117 (define-syntax-rule (let/time ((time result exp)) body ...)
 118   (call-with-time (lambda () exp) (lambda (time result) body ...)))
 119
 120 (define (histogram field proc seed lst)
 121   "Return an alist giving a histogram of all the values of FIELD for elements
 122 of LST. FIELD must be a one element procedure that returns a field's value.
 123 For each FIELD value, call PROC with the previous field-specific result.
 124 Example:
 125
 126   (histogram car (lambda (x n) (+ 1 n)) 0 '((a . x)(b . y)(a . z)))
 127   => ((a . 2) (b . 1))
 128
 129 meaning that we have two a's and one b."
 130   (let loop ((lst lst)
 131              (result '()))
 132     (match lst
 133       (()
 134        result)
 135       ((head . tail)
 136        (let ((value (field head)))
 137          (loop tail
 138                (match (assoc-ref result value)
 139                  (#f
 140                   `((,value . ,(proc head seed)) ,@result))
 141                  (previous
 142                   `((,value . ,(proc head previous))
 143                     ,@(alist-delete value result))))))))))
 144
 145 (define (throughput lst timestamp)
 146   "Return the throughput, in items per second, given the elements of LST,
 147 calling TIMESTAMP to get the \"timestamp\" of each item."
 148   (let ((oldest (reduce min +inf.0 (map build-timestamp lst)))
 149         (now    (time-second (current-time time-utc))))
 150     (/ (length lst) (- now oldest) 1.)))
 151
 152 (define (queued-subset queue items)
 153   "Return the subset of ITEMS, a list of store file names, that appears in
 154 QUEUE, a list of builds.  Return #f if elements in QUEUE lack information
 155 about the derivations queued, as is the case with Hydra."
 156   (define queued
 157     (append-map (lambda (build)
 158                   (match (false-if-exception
 159                           (read-derivation-from-file (build-derivation build)))
 160                     (#f
 161                      '())
 162                     (drv
 163                      (match (derivation->output-paths drv)
 164                        (((names . items) ...) items)))))
 165                 queue))
 166
 167   (if (any (negate build-derivation) queue)
 168       #f                                          ;no derivation information
 169       (lset-intersection string=? queued items)))
 170
 171 (define* (report-server-coverage server items
 172                                  #:key display-missing?)
 173   "Report the subset of ITEMS available as substitutes on SERVER.
 174 When DISPLAY-MISSING? is true, display the list of missing substitutes.
 175 Return the coverage ratio, an exact number between 0 and 1."
 176   (define MiB (* (expt 2 20) 1.))
 177
 178   (format #t (G_ "looking for ~h store items on ~a...~%")
 179           (length items) server)
 180
 181   (let/time ((time narinfos (lookup-narinfos server items)))
 182     (format #t "~a~%" server)
 183     (let ((obtained  (length narinfos))
 184           (requested (length items))
 185           (missing   (lset-difference string=?
 186                                       items (map narinfo-path narinfos)))
 187           (sizes     (append-map (lambda (narinfo)
 188                                    (filter integer?
 189                                            (narinfo-file-sizes narinfo)))
 190                                  narinfos))
 191           (time      (+ (time-second time)
 192                         (/ (time-nanosecond time) 1e9))))
 193       (format #t (G_ "  ~,1f% substitutes available (~h out of ~h)~%")
 194               (* 100. (/ obtained requested 1.))
 195               obtained requested)
 196       (let ((total (/ (reduce + 0 sizes) MiB)))
 197         (match (length sizes)
 198           ((? zero?)
 199            (format #t (G_  "  unknown substitute sizes~%")))
 200           (len
 201            (if (= len obtained)
 202                (format #t (G_ "  ~,1h MiB of nars (compressed)~%") total)
 203                (format #t (G_ "  at least ~,1h MiB of nars (compressed)~%")
 204                        total)))))
 205       (format #t (G_ "  ~,1h MiB on disk (uncompressed)~%")
 206               (/ (reduce + 0 (map narinfo-size narinfos)) MiB))
 207       (format #t (G_ "  ~,3h seconds per request (~,1h seconds in total)~%")
 208               (/ time requested 1.) time)
 209       (format #t (G_ "  ~,1h requests per second~%")
 210               (/ requested time 1.))
 211
 212       (guard (c ((http-get-error? c)
 213                  (if (= 404 (http-get-error-code c))
 214                      (format (current-error-port)
 215                              (G_ "  (continuous integration information \
 216 unavailable)~%"))
 217                      (format (current-error-port)
 218                              (G_ "  '~a' returned ~a (~s)~%")
 219                              (uri->string (http-get-error-uri c))
 220                              (http-get-error-code c)
 221                              (http-get-error-reason c)))))
 222         (let* ((max    %query-limit)
 223                (queue  (queued-builds server max))
 224                (len    (length queue))
 225                (histo  (histogram build-system
 226                                   (lambda (build count)
 227                                     (+ 1 count))
 228                                   0 queue)))
 229           (newline)
 230           (unless (null? missing)
 231             (match (queued-subset queue missing)
 232               (#f #f)
 233               ((= length queued)
 234                (let ((missing (length missing)))
 235                  (format #t (G_ "  ~,1f% (~h out of ~h) of the missing items \
 236 are queued~%")
 237                          (* 100. (/ queued missing))
 238                          queued missing)))))
 239
 240           (if (>= len max)
 241               (format #t (G_ "  at least ~h queued builds~%") len)
 242               (format #t (G_ "  ~h queued builds~%") len))
 243           (for-each (match-lambda
 244                       ((system . count)
 245                        (format #t (G_ "      ~a: ~a (~0,1f%)~%")
 246                                system count (* 100. (/ count len)))))
 247                     histo))
 248
 249         (let* ((latest     (latest-builds server))
 250                (builds/sec (throughput latest build-timestamp)))
 251           (format #t (G_ "  build rate: ~1,2f builds per hour~%")
 252                   (* builds/sec 3600.))
 253           (for-each (match-lambda
 254                       ((system . builds)
 255                        (format #t (G_ "      ~a: ~,2f builds per hour~%")
 256                                system
 257                                (* (throughput builds build-timestamp)
 258                                   3600.))))
 259                     (histogram build-system cons '() latest))))
 260
 261       (when (and display-missing? (not (null? missing)))
 262         (newline)
 263         (format #t (G_ "Substitutes are missing for the following items:~%"))
 264         (format #t "~{  ~a~%~}" missing))
 265
 266       ;; Return the coverage ratio.
 267       (let ((total (length items)))
 268         (/ (- total (length missing)) total)))))
 269
 270 \f
 271 ;;;
 272 ;;; Command-line options.
 273 ;;;
 274
 275 (define (show-help)
 276   (display (G_ "Usage: guix weather [OPTIONS] [PACKAGES ...]
 277 Report the availability of substitutes.\n"))
 278   (display (G_ "
 279       --substitute-urls=URLS
 280                          check for available substitutes at URLS"))
 281   (display (G_ "
 282   -m, --manifest=MANIFEST
 283                          look up substitutes for packages specified in MANIFEST"))
 284   (display (G_ "
 285   -c, --coverage[=COUNT]
 286                          show substitute coverage for packages with at least
 287                          COUNT dependents"))
 288   (display (G_ "
 289       --display-missing  display the list of missing substitutes"))
 290   (display (G_ "
 291   -s, --system=SYSTEM    consider substitutes for SYSTEM--e.g., \"i686-linux\""))
 292   (newline)
 293   (display (G_ "
 294   -h, --help             display this help and exit"))
 295   (display (G_ "
 296   -V, --version          display version information and exit"))
 297   (newline)
 298   (show-bug-report-information))
 299
 300 (define %options
 301   (list  (option '(#\h "help") #f #f
 302                  (lambda args
 303                    (show-help)
 304                    (exit 0)))
 305          (option '(#\V "version") #f #f
 306                  (lambda args
 307                    (show-version-and-exit "guix weather")))
 308
 309          (option '("substitute-urls") #t #f
 310                  (lambda (opt name arg result . rest)
 311                    (let ((urls (string-tokenize arg)))
 312                      (for-each (lambda (url)
 313                                  (unless (string->uri url)
 314                                    (leave (G_ "~a: invalid URL~%") url)))
 315                                urls)
 316                      (apply values
 317                             (alist-cons 'substitute-urls urls
 318                                         (alist-delete 'substitute-urls result))
 319                             rest))))
 320          (option '(#\m "manifest") #t #f
 321                  (lambda (opt name arg result)
 322                    (alist-cons 'manifest arg result)))
 323          (option '(#\c "coverage") #f #t
 324                  (lambda (opt name arg result)
 325                    (alist-cons 'coverage
 326                                (if arg (string->number* arg) 0)
 327                                result)))
 328          (option '("display-missing") #f #f
 329                  (lambda (opt name arg result)
 330                    (alist-cons 'display-missing? #t result)))
 331          (option '(#\s "system") #t #f
 332                  (lambda (opt name arg result)
 333                    (alist-cons 'system arg result)))))
 334
 335 (define %default-options
 336   `((substitute-urls . ,%default-substitute-urls)))
 337
 338 (define (load-manifest file)
 339   "Load the manifest from FILE and return the list of packages it refers to."
 340   (let* ((user-module (make-user-module '((guix profiles) (gnu))))
 341          (manifest    (load* file user-module)))
 342     (delete-duplicates (map manifest-entry-item
 343                             (manifest-transitive-entries manifest))
 344                        eq?)))
 345
 346 \f
 347 ;;;
 348 ;;; Missing package substitutes.
 349 ;;;
 350
 351 (define* (package-partition-boundary pred packages
 352                                      #:key (system (%current-system)))
 353   "Return the subset of PACKAGES that are at the \"boundary\" between those
 354 that match PRED and those that don't.  The returned packages themselves do not
 355 match PRED but they have at least one direct dependency that does.
 356
 357 Note: The assumption is that, if P matches PRED, then all the dependencies of
 358 P match PRED as well."
 359   ;; XXX: Graph theoreticians surely have something to teach us about this...
 360   (let loop ((packages packages)
 361              (result (setq))
 362              (visited vlist-null))
 363     (define (visited? package)
 364       (vhash-assq package visited))
 365
 366     (match packages
 367       ((package . rest)
 368        (cond ((visited? package)
 369               (loop rest result visited))
 370              ((pred package)
 371               (loop rest result (vhash-consq package #t visited)))
 372              (else
 373               (let* ((bag  (package->bag package system))
 374                      (deps (filter-map (match-lambda
 375                                          ((label (? package? package) . _)
 376                                           (and (not (pred package))
 377                                                package))
 378                                          (_ #f))
 379                                        (bag-direct-inputs bag))))
 380                 (loop (append deps rest)
 381                       (if (null? deps)
 382                           (set-insert package result)
 383                           result)
 384                       (vhash-consq package #t visited))))))
 385       (()
 386        (set->list result)))))
 387
 388 (define (package->output-mapping packages system)
 389   "Return a vhash that maps each item of PACKAGES to its corresponding output
 390 store file names for SYSTEM."
 391   (foldm %store-monad
 392          (lambda (package mapping)
 393            (mlet %store-monad ((drv (package->derivation package system
 394                                                          #:graft? #f)))
 395              (return (vhash-consq package
 396                                   (match (derivation->output-paths drv)
 397                                     (((names . outputs) ...)
 398                                      outputs))
 399                                   mapping))))
 400          vlist-null
 401          packages))
 402
 403 (define (substitute-oracle server items)
 404   "Return a procedure that, when passed a store item (one of those listed in
 405 ITEMS), returns true if SERVER has a substitute for it, false otherwise."
 406   (define available
 407     (fold (lambda (narinfo set)
 408             (set-insert (narinfo-path narinfo) set))
 409           (set)
 410           (lookup-narinfos server items)))
 411
 412   (cut set-contains? available <>))
 413
 414 (define* (report-package-coverage-per-system server packages system
 415                                              #:key (threshold 0))
 416   "Report on the subset of PACKAGES that lacks SYSTEM substitutes on SERVER,
 417 sorted by decreasing number of dependents.  Do not display those with less
 418 than THRESHOLD dependents."
 419   (mlet* %store-monad ((packages -> (package-closure packages #:system system))
 420                        (mapping    (package->output-mapping packages system))
 421                        (back-edges (node-back-edges %bag-node-type packages)))
 422     (define items
 423       (vhash-fold (lambda (package items result)
 424                     (append items result))
 425                   '()
 426                   mapping))
 427
 428     (define substitutable?
 429       (substitute-oracle server items))
 430
 431     (define substitutable-package?
 432       (lambda (package)
 433         (match (vhash-assq package mapping)
 434           ((_ . items)
 435            (find substitutable? items))
 436           (#f
 437            #f))))
 438
 439     (define missing
 440       (package-partition-boundary substitutable-package? packages
 441                                   #:system system))
 442
 443     (define missing-count
 444       (length missing))
 445
 446     (if (zero? threshold)
 447         (format #t (N_ "The following ~a package is missing from '~a' for \
 448 '~a':~%"
 449                        "The following ~a packages are missing from '~a' for \
 450 '~a':~%"
 451                        missing-count)
 452                 missing-count server system)
 453         (format #t (N_ "~a package is missing from '~a' for '~a':~%"
 454                        "~a packages are missing from '~a' for '~a', among \
 455 which:~%"
 456                        missing-count)
 457                 missing-count server system))
 458
 459     (for-each (match-lambda
 460                 ((package count)
 461                  (match (vhash-assq package mapping)
 462                    ((_ . items)
 463                     (when (>= count threshold)
 464                       (format #t "  ~4d\t~a@~a\t~{~a ~}~%"
 465                               count
 466                               (package-name package) (package-version package)
 467                               items)))
 468                    (#f                      ;PACKAGE must be an internal thing
 469                     #f))))
 470               (sort (zip missing
 471                          (map (lambda (package)
 472                                 (node-reachable-count (list package)
 473                                                       back-edges))
 474                               missing))
 475                     (match-lambda*
 476                       (((_ count1) (_ count2))
 477                        (< count2 count1)))))
 478     (return #t)))
 479
 480 (define* (report-package-coverage server packages systems
 481                                   #:key (threshold 0))
 482   "Report on the substitute coverage for PACKAGES, for each of SYSTEMS, on
 483 SERVER.  Display information for packages with at least THRESHOLD dependents."
 484   (with-store store
 485     (run-with-store store
 486       (foldm %store-monad
 487              (lambda (system _)
 488                (report-package-coverage-per-system server packages system
 489                                                    #:threshold threshold))
 490              #f
 491              systems))))
 492
 493 \f
 494 ;;;
 495 ;;; Entry point.
 496 ;;;
 497
 498 (define-command (guix-weather . args)
 499   (synopsis "report on the availability of pre-built package binaries")
 500
 501   (define (package-list opts)
 502     ;; Return the package list specified by OPTS.
 503     (let ((files (filter-map (match-lambda
 504                                (('manifest . file) file)
 505                                (_ #f))
 506                              opts))
 507           (base  (filter-map (match-lambda
 508                                (('argument . spec)
 509                                 (specification->package spec))
 510                                (_
 511                                 #f))
 512                              opts)))
 513       (if (and (null? files) (null? base))
 514           (all-packages)
 515           (append base (append-map load-manifest files)))))
 516
 517   (with-error-handling
 518     (parameterize ((current-terminal-columns (terminal-columns))
 519
 520                    ;; Set grafting upfront in case the user's input depends on
 521                    ;; it (e.g., a manifest or code snippet that calls
 522                    ;; 'gexp->derivation').
 523                    (%graft?                  #f))
 524       (let* ((opts     (parse-command-line args %options
 525                                            (list %default-options)
 526                                            #:build-options? #f))
 527              (urls     (assoc-ref opts 'substitute-urls))
 528              (systems  (match (filter-map (match-lambda
 529                                             (('system . system) system)
 530                                             (_ #f))
 531                                           opts)
 532                          (() (list (%current-system)))
 533                          (systems systems)))
 534              (packages (package-list opts))
 535              (items    (with-store store
 536                          (concatenate
 537                           (run-with-store store
 538                             (mapm %store-monad
 539                                   (lambda (system)
 540                                     (package-outputs packages system))
 541                                   systems))))))
 542         (exit
 543          (every (lambda (server)
 544                   (define coverage
 545                     (report-server-coverage server items
 546                                             #:display-missing?
 547                                             (assoc-ref opts 'display-missing?)))
 548                   (match (assoc-ref opts 'coverage)
 549                     (#f #f)
 550                     (threshold
 551                      ;; PACKAGES may include non-package objects coming from a
 552                      ;; manifest.  Filter them out.
 553                      (report-package-coverage server
 554                                               (filter package? packages)
 555                                               systems
 556                                               #:threshold threshold)))
 557
 558                   (= 1 coverage))
 559                 urls))))))
 560
 561 ;;; Local Variables:
 562 ;;; eval: (put 'let/time 'scheme-indent-function 1)
 563 ;;; End: