Add 'guix weather'.

* guix/scripts/weather.scm: New file.
* Makefile.am (MODULES): Add it.
* doc/guix.texi (Substitutes, Invoking guix publish): Mention "guix
weather".
(Invoking guix weather): New node.

Co-authored-by: Ricardo Wurmus <rekado@elephly.net>

3 files changed, 309 insertions, 1 deletions

diff --git a/Makefile.am b/Makefile.am
index 4d1512f8ce..5888bc0266 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -171,6 +171,7 @@ MODULES =					\
   guix/scripts/import/texlive.scm  		\
   guix/scripts/environment.scm			\
   guix/scripts/publish.scm			\
+  guix/scripts/weather.scm			\
   guix/scripts/edit.scm				\
   guix/scripts/size.scm				\
   guix/scripts/graph.scm			\
diff --git a/doc/guix.texi b/doc/guix.texi
index dfa1e22fcc..932b118f7d 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -158,6 +158,7 @@ Utilities
 * Invoking guix challenge::     Challenging substitute servers.
 * Invoking guix copy::          Copying to and from a remote store.
 * Invoking guix container::     Process isolation.
+* Invoking guix weather::       Assessing substitute availability.
 
 Invoking @command{guix build}
 
@@ -2201,6 +2202,9 @@ authenticates substitute information itself, as explained above, which
 is what we care about (whereas X.509 certificates are about
 authenticating bindings between domain names and public keys.)
 
+You can get statistics on the substitutes provided by a server using the
+@command{guix weather} command (@pxref{Invoking guix weather}).
+
 The substitute mechanism can be disabled globally by running
 @code{guix-daemon} with @code{--no-substitutes} (@pxref{Invoking
 guix-daemon}).  It can also be disabled temporarily by passing the
@@ -4933,6 +4937,7 @@ the Scheme programming interface of Guix in a convenient way.
 * Invoking guix challenge::     Challenging substitute servers.
 * Invoking guix copy::          Copying to and from a remote store.
 * Invoking guix container::     Process isolation.
+* Invoking guix weather::       Assessing substitute availability.
 @end menu
 
 @node Invoking guix build
@@ -6869,7 +6874,8 @@ serves them.  This ``on-the-fly'' mode is convenient in that it requires
 no setup and is immediately available.  However, when serving lots of
 clients, we recommend using the @option{--cache} option, which enables
 caching of the archives before they are sent to clients---see below for
-details.
+details.  The @command{guix weather} command provides a handy way to
+check what a server provides (@pxref{Invoking guix weather}).
 
 As a bonus, @command{guix publish} also serves as a content-addressed
 mirror for source files referenced in @code{origin} records
@@ -7269,6 +7275,73 @@ must be PID 1 of the container or one of its child processes.
 
 @end table
 
+@node Invoking guix weather
+@section Invoking @command{guix weather}
+
+Occasionally you're grumpy because substitutes are lacking and you end
+up building packages by yourself (@pxref{Substitutes}).  The
+@command{guix weather} command reports on substitute availability on the
+specified servers so you can have an idea of whether you'll be grumpy
+today.  It can sometimes be useful info as a user, but it is primarily
+useful to people running @command{guix publish} (@pxref{Invoking guix
+publish}).
+
+@cindex statistics, for substitutes
+@cindex availability of substitutes
+@cindex substitute availability
+@cindex weather, substitute availability
+Here's a sample run:
+
+@example
+$ guix weather --substitute-urls=https://guix.example.org
+computing 5,872 package derivations for x86_64-linux...
+looking for 6,128 store items on https://guix.example.org..
+updating list of substitutes from 'https://guix.example.org'... 100.0%
+https://guix.example.org
+  43.4% substitutes available (2,658 out of 6,128)
+  7,032.5 MiB of nars (compressed)
+  19,824.2 MiB on disk (uncompressed)
+  0.030 seconds per request (182.9 seconds in total)
+  33.5 requests per second
+@end example
+
+As you can see, it reports the fraction of all the packages for which
+substitutes are available on the server---regardless of whether
+substitutes are enabled, and regardless of whether this server's signing
+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.
+
+To achieve that, @command{guix weather} queries over HTTP(S) meta-data
+(@dfn{narinfos}) for all the relevant store items.  Like @command{guix
+challenge}, it ignores signatures on those substitutes, which is
+innocuous since the command only gathers statistics and cannot install
+those substitutes.
+
+Among other things, it is possible to query specific system types and
+specific package sets.  The available options are listed below.
+
+@table @code
+@item --substitute-urls=@var{urls}
+@var{urls} is the space-separated list of substitute server URLs to
+query.  When this option is omitted, the default set of substitute
+servers is queried.
+
+@item --system=@var{system}
+@itemx -s @var{system}
+Query substitutes for @var{system}---e.g., @code{aarch64-linux}.  This
+option can be repeated, in which case @command{guix weather} will query
+substitutes for several system types.
+
+@item --manifest=@var{file}
+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}).
+@end table
+
+
 @c *********************************************************************
 @node GNU Distribution
 @chapter GNU Distribution
diff --git a/guix/scripts/weather.scm b/guix/scripts/weather.scm
new file mode 100644
index 0000000000..9cbeedd288
--- /dev/null
+++ b/guix/scripts/weather.scm
@@ -0,0 +1,234 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2017 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2017 Ricardo Wurmus <rekado@elephly.net>
+;;;
+;;; 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 profiles)
+  #: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 (web uri)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-19)
+  #:use-module (srfi srfi-26)
+  #: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."
+  (let ((packages (filter (cut supported-package? <> system) packages)))
+
+    (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_ "
+      --manifest=MANIFEST
+                         look up substitutes for packages specified in MANIFEST"))
+  (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)
+                   (let ((urls (string-tokenize arg)))
+                     (for-each (lambda (url)
+                                 (unless (string->uri url)
+                                   (leave (G_ "~a: invalid URL~%") url)))
+                               urls)
+                     (apply values
+                            (alist-cons 'substitute-urls urls
+                                        (alist-delete 'substitute-urls result))
+                            rest))))
+         (option '(#\m "manifest") #t #f
+                 (lambda (opt name arg result)
+                   (alist-cons 'manifest arg result)))
+         (option '(#\s "system") #t #f
+                 (lambda (opt name arg result)
+                   (alist-cons 'system arg result)))))
+
+(define %default-options
+  `((substitute-urls . ,%default-substitute-urls)))
+
+(define (load-manifest file)
+  "Load the manifest from FILE and return the list of packages it refers to."
+  (let* ((user-module (make-user-module '((guix profiles) (gnu))))
+         (manifest    (load* file user-module)))
+    (map manifest-entry-item
+         (manifest-transitive-entries manifest))))
+
+
+;;;
+;;; 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 (let ((file (assoc-ref opts 'manifest)))
+                       (if file
+                           (load-manifest file)
+                           (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: