2017-07-25 06:14:04 -04:00
|
|
|
|
;;; 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_ "
|
2017-07-27 05:05:03 -04:00
|
|
|
|
-m, --manifest=MANIFEST
|
2017-07-25 06:14:04 -04:00
|
|
|
|
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:
|
