234 lines
9.0 KiB
Scheme
234 lines
9.0 KiB
Scheme
;;; 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 progress)
|
||
#:use-module (guix monads)
|
||
#:use-module (guix store)
|
||
#:use-module (guix grafts)
|
||
#:use-module ((guix build syscalls) #:select (terminal-columns))
|
||
#: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 (call-with-progress-reporter reporter proc)
|
||
"This is a variant of 'call-with-progress-reporter' that works with monadic
|
||
scope."
|
||
;; TODO: Move to a more appropriate place.
|
||
(with-monad %store-monad
|
||
(start-progress-reporter! reporter)
|
||
(mlet* %store-monad ((report -> (lambda ()
|
||
(progress-reporter-report! reporter)))
|
||
(result (proc report)))
|
||
(stop-progress-reporter! reporter)
|
||
(return 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)))
|
||
(format (current-error-port)
|
||
(G_ "computing ~h package derivations for ~a...~%")
|
||
(length packages) system)
|
||
|
||
(call-with-progress-reporter (progress-reporter/bar (length packages))
|
||
(lambda (report)
|
||
(foldm %store-monad
|
||
(lambda (package result)
|
||
(mlet %store-monad ((drv (package->derivation package system
|
||
#:graft? #f)))
|
||
(report)
|
||
(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_ "
|
||
-m, --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
|
||
(parameterize ((current-terminal-columns (terminal-columns)))
|
||
(let* ((opts (parse-command-line args %options
|
||
(list %default-options)
|
||
#:build-options? #f))
|
||
(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:
|