What’s the weather like?

[Ludovic Courtès]

Hello Guix!

Lately we’ve had a lot of nar URLs return 404, mostly for server-side
issues (setup issue on hydra.gnu.org that broke ‘guix publish’ cache
management, and a ‘guix publish’ cache eviction policy that’s too
aggressive.)

The attached tool allows you to query the status a substitute server
(and, as a side effect, triggers a nar regeneration if the server uses
‘guix publish --cache’).  So it goes like this:

--8<---------------cut here---------------start------------->8---
$ ./pre-inst-env guix weather --substitute-urls=https://hydra.gnu.org
computing 5,864 package derivations for x86_64-linux...
looking for 6,121 store items on https://hydra.gnu.org...
updating list of substitutes from 'https://hydra.gnu.org'... 100.0%
https://hydra.gnu.org
  81.2% substitutes available (4,970 out of 6,121)
  17,852.6 MiB of nars (compressed)
  46,415.5 MiB on disk (uncompressed)
  0.050 seconds per request (306.0 seconds in total)
  20.0 requests per second
--8<---------------cut here---------------end--------------->8---

Here it’s telling us that hydra.gnu.org has 81% of the substitutes for
x86_64 of the current public packages (those shown by “guix package
-A”).

We can add multiple -s flags, thought that quickly takes ages,
especially on that box.

Thoughts?

Ludo’.

;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2017 Ludovic Courtès <address@hidden>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.

(define-module (guix scripts weather)
  #:use-module (guix ui)
  #:use-module (guix scripts)
  #:use-module (guix packages)
  #:use-module (guix derivations)
  #:use-module (guix monads)
  #:use-module (guix store)
  #:use-module (guix grafts)
  #:use-module (guix build syscalls)
  #:use-module (guix scripts substitute)
  #:use-module (gnu packages)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-19)
  #:use-module (srfi srfi-37)
  #:use-module (ice-9 match)
  #:use-module (ice-9 format)
  #:export (guix-weather))


(define (all-packages)
  "Return the list of public packages we are going to query."
  (fold-packages (lambda (package result)
                   (match (package-replacement package)
                     ((? package? replacement)
                      (cons* replacement package result))
                     (#f
                      (cons package result))))
                 '()))

(define* (package-outputs packages
                          #:optional (system (%current-system)))
  "Return the list of outputs of all of PACKAGES for the given SYSTEM."
  (define update-progress!
    (let ((total (length packages))
          (done  0)
          (width (max 10 (- (terminal-columns) 10))))
      (lambda ()
        (set! done (+ 1 done))
        (let* ((ratio (/ done total 1.))
               (done  (inexact->exact (round (* width ratio))))
               (left  (- width done)))
          (format (current-error-port) "~5,1f% [~a~a]\r"
                  (* ratio 100.)
                  (make-string done #\#)
                  (make-string left #\space))
          (when (>= done total)
            (newline (current-error-port)))
          (force-output (current-error-port))))))

  (format (current-error-port)
          (G_ "computing ~h package derivations for ~a...~%")
          (length packages) system)

  (foldm %store-monad
         (lambda (package result)
           (mlet %store-monad ((drv (package->derivation package system
                                                         #:graft? #f)))
             (update-progress!)
             (match (derivation->output-paths drv)
               (((names . items) ...)
                (return (append items result))))))
         '()
         packages))

(cond-expand
  (guile-2.2
   ;; Guile 2.2.2 has a bug whereby 'time-monotonic' objects have seconds and
   ;; nanoseconds swapped (fixed in Guile commit 886ac3e).  Work around it.
   (define time-monotonic time-tai))
  (else #t))

(define (call-with-time thunk kont)
  "Call THUNK and pass KONT the elapsed time followed by THUNK's return
values."
  (let* ((start  (current-time time-monotonic))
         (result (call-with-values thunk list))
         (end    (current-time time-monotonic)))
    (apply kont (time-difference end start) result)))

(define-syntax-rule (let/time ((time result exp)) body ...)
  (call-with-time (lambda () exp) (lambda (time result) body ...)))

(define (report-server-coverage server items)
  "Report the subset of ITEMS available as substitutes on SERVER."
  (define MiB (* (expt 2 20) 1.))

  (format #t (G_ "looking for ~h store items on ~a...~%")
          (length items) server)

  (let/time ((time narinfos (lookup-narinfos server items)))
    (format #t "~a~%" server)
    (let ((obtained  (length narinfos))
          (requested (length items))
          (sizes     (filter-map narinfo-file-size narinfos))
          (time      (+ (time-second time)
                        (/ (time-nanosecond time) 1e9))))
      (format #t (G_ "  ~2,1f% substitutes available (~h out of ~h)~%")
              (* 100. (/ obtained requested 1.))
              obtained requested)
      (let ((total (/ (reduce + 0 sizes) MiB)))
        (match (length sizes)
          ((? zero?)
           (format #t (G_  "unknown substitute sizes~%")))
          (len
           (if (= len obtained)
               (format #t (G_ "  ~,1h MiB of nars (compressed)~%") total)
               (format #t (G_ "  at least ~,1h MiB of nars (compressed)~%")
                       total)))))
      (format #t (G_ "  ~,1h MiB on disk (uncompressed)~%")
              (/ (reduce + 0 (map narinfo-size narinfos)) MiB))
      (format #t (G_ "  ~,3h seconds per request (~,1h seconds in total)~%")
              (/ time requested 1.) time)
      (format #t (G_ "  ~,1h requests per second~%")
              (/ requested time 1.)))))


;;;
;;; Command-line options.
;;;

(define (show-help)
  (display (G_ "Usage: guix weather [OPTIONS]
Report the availability of substitutes.\n"))
  (display (G_ "
      --substitute-urls=URLS
                         check for available substitutes at URLS"))
  (display (G_ "
  -s, --system=SYSTEM    consider substitutes for SYSTEM--e.g., 
\"i686-linux\""))
  (newline)
  (display (G_ "
  -h, --help             display this help and exit"))
  (display (G_ "
  -V, --version          display version information and exit"))
  (newline)
  (show-bug-report-information))

(define %options
  (list  (option '(#\h "help") #f #f
                 (lambda args
                   (show-help)
                   (exit 0)))
         (option '(#\V "version") #f #f
                 (lambda args
                   (show-version-and-exit "guix challenge")))

         (option '("substitute-urls") #t #f
                 (lambda (opt name arg result . rest)
                   (apply values
                          (alist-cons 'substitute-urls
                                      (string-tokenize arg)
                                      (alist-delete 'substitute-urls result))
                          rest)))
         (option '(#\s "system") #t #f
                 (lambda (opt name arg result)
                   (alist-cons 'system arg result)))))

(define %default-options
  `((substitute-urls . ,%default-substitute-urls)))


;;;
;;; Entry point.
;;;

(define (guix-weather . args)
  (with-error-handling
    (let* ((opts     (parse-command-line args %options
                                         (list %default-options)))
           (urls     (assoc-ref opts 'substitute-urls))
           (systems  (match (filter-map (match-lambda
                                          (('system . system) system)
                                          (_ #f))
                                        opts)
                       (() (list (%current-system)))
                       (systems systems)))
           (packages (all-packages))
           (items    (with-store store
                       (parameterize ((%graft? #f))
                         (concatenate
                          (run-with-store store
                            (mapm %store-monad
                                  (lambda (system)
                                    (package-outputs packages system))
                                  systems)))))))
      (for-each (lambda (server)
                  (report-server-coverage server items))
                urls))))

;;; Local Variables:
;;; eval: (put 'let/time 'scheme-indent-function 1)
;;; End: