guix/scripts/weather.scm

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