nixo
/
guix-devel
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity
guix-devel/guix/scripts/weather.scm

235 lines
8.8 KiB
Scheme
Raw Normal View History

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>
2017-07-25 12:14:04 +02: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_ "
weather: Show "-m" option in help message. Reported by Alex Kost <alezost@gmail.com>. * guix/scripts/weather.scm (show-help): Show "-m".
2017-07-27 11:05:03 +02:00
-m, --manifest=MANIFEST
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>
2017-07-25 12:14:04 +02: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: