diff options
Diffstat (limited to 'guix/scripts')
| -rw-r--r-- | guix/scripts/build.scm | 4 | ||||
| -rw-r--r-- | guix/scripts/describe.scm | 2 | ||||
| -rw-r--r-- | guix/scripts/import.scm | 2 | ||||
| -rw-r--r-- | guix/scripts/import/go.scm | 118 | ||||
| -rw-r--r-- | guix/scripts/package.scm | 5 | ||||
| -rwxr-xr-x | guix/scripts/substitute.scm | 122 | ||||
| -rw-r--r-- | guix/scripts/system.scm | 8 | ||||
| -rw-r--r-- | guix/scripts/time-machine.scm | 5 | ||||
| -rw-r--r-- | guix/scripts/weather.scm | 20 |
9 files changed, 254 insertions, 32 deletions
diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm index a959cb827d..fa1bbf867d 100644 --- a/guix/scripts/build.scm +++ b/guix/scripts/build.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021, 2021 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2013 Mark H Weaver <mhw@netris.org> ;;; Copyright © 2020 Marius Bakke <mbakke@fastmail.com> ;;; Copyright © 2020 Ricardo Wurmus <rekado@elephly.net> @@ -22,7 +22,7 @@ (define-module (guix scripts build) #:use-module (guix ui) #:use-module (guix scripts) - #:use-module (guix import json) + #:autoload (guix import json) (json->scheme-file) #:use-module (guix store) #:use-module (guix derivations) #:use-module (guix packages) diff --git a/guix/scripts/describe.scm b/guix/scripts/describe.scm index 6f8d9aceec..be2279d254 100644 --- a/guix/scripts/describe.scm +++ b/guix/scripts/describe.scm @@ -28,7 +28,7 @@ #:use-module (guix profiles) #:autoload (guix openpgp) (openpgp-format-fingerprint) #:use-module (git) - #:use-module (json) + #:autoload (json builder) (scm->json-string) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) #:use-module (srfi srfi-37) diff --git a/guix/scripts/import.scm b/guix/scripts/import.scm index 0a3863f965..1d2b45d942 100644 --- a/guix/scripts/import.scm +++ b/guix/scripts/import.scm @@ -77,7 +77,7 @@ rather than \\n." ;;; (define importers '("gnu" "nix" "pypi" "cpan" "hackage" "stackage" "elpa" "gem" - "cran" "crate" "texlive" "json" "opam")) + "go" "cran" "crate" "texlive" "json" "opam")) (define (resolve-importer name) (let ((module (resolve-interface diff --git a/guix/scripts/import/go.scm b/guix/scripts/import/go.scm new file mode 100644 index 0000000000..afdba4e8f1 --- /dev/null +++ b/guix/scripts/import/go.scm @@ -0,0 +1,118 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2020 Katherine Cox-Buday <cox.katherine.e@gmail.com> +;;; +;;; 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 import go) + #:use-module (guix ui) + #:use-module (guix utils) + #:use-module (guix scripts) + #:use-module (guix import go) + #:use-module (guix scripts import) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-11) + #:use-module (srfi srfi-37) + #:use-module (ice-9 match) + #:use-module (ice-9 format) + #:export (guix-import-go)) + + +;;; +;;; Command-line options. +;;; + +(define %default-options + '()) + +(define (show-help) + (display (G_ "Usage: guix import go PACKAGE-PATH +Import and convert the Go module for PACKAGE-PATH.\n")) + (display (G_ " + -h, --help display this help and exit")) + (display (G_ " + -V, --version display version information and exit")) + (display (G_ " + -r, --recursive generate package expressions for all Go modules\ + that are not yet in Guix")) + (display (G_ " + -p, --goproxy=GOPROXY specify which goproxy server to use")) + (newline) + (show-bug-report-information)) + +(define %options + ;; Specification of the command-line options. + (cons* (option '(#\h "help") #f #f + (lambda args + (show-help) + (exit 0))) + (option '(#\V "version") #f #f + (lambda args + (show-version-and-exit "guix import go"))) + (option '(#\r "recursive") #f #f + (lambda (opt name arg result) + (alist-cons 'recursive #t result))) + (option '(#\p "goproxy") #t #f + (lambda (opt name arg result) + (alist-cons 'goproxy + (string->symbol arg) + (alist-delete 'goproxy result)))) + %standard-import-options)) + + +;;; +;;; Entry point. +;;; + +(define (guix-import-go . args) + (define (parse-options) + ;; Return the alist of option values. + (args-fold* args %options + (lambda (opt name arg result) + (leave (G_ "~A: unrecognized option~%") name)) + (lambda (arg result) + (alist-cons 'argument arg result)) + %default-options)) + + (let* ((opts (parse-options)) + (args (filter-map (match-lambda + (('argument . value) + value) + (_ #f)) + (reverse opts)))) + (match args + ((module-name) + (if (assoc-ref opts 'recursive) + (map (match-lambda + ((and ('package ('name name) . rest) pkg) + `(define-public ,(string->symbol name) + ,pkg)) + (_ #f)) + (go-module-recursive-import module-name + #:goproxy-url + (or (assoc-ref opts 'goproxy) + "https://proxy.golang.org"))) + (let ((sexp (go-module->guix-package module-name + #:goproxy-url + (or (assoc-ref opts 'goproxy) + "https://proxy.golang.org")))) + (unless sexp + (leave (G_ "failed to download meta-data for module '~a'~%") + module-name)) + sexp))) + (() + (leave (G_ "too few arguments~%"))) + ((many ...) + (leave (G_ "too many arguments~%")))))) diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index fc5bf8137b..e3d40d5142 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -35,14 +35,15 @@ #:use-module (guix packages) #:use-module (guix profiles) #:use-module (guix search-paths) - #:use-module (guix import json) + #:autoload (guix import json) (json->scheme-file) #:use-module (guix monads) #:use-module (guix utils) #:use-module (guix config) #:use-module (guix scripts) #:use-module (guix scripts build) #:use-module (guix transformations) - #:use-module (guix describe) + #:autoload (guix describe) (manifest-entry-provenance + manifest-entry-with-provenance) #:autoload (guix channels) (channel-name channel-commit channel->code) #:autoload (guix store roots) (gc-roots user-owned?) #:use-module ((guix build utils) diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm index 5866b8bb0a..46323c7216 100755 --- a/guix/scripts/substitute.scm +++ b/guix/scripts/substitute.scm @@ -45,6 +45,7 @@ #:select (uri-abbreviation nar-uri-abbreviation (open-connection-for-uri . guix:open-connection-for-uri))) + #:autoload (gnutls) (error/invalid-session) #:use-module (guix progress) #:use-module ((guix build syscalls) #:select (set-thread-name)) @@ -257,6 +258,27 @@ Internal tool to substitute a pre-built binary to a local build.\n")) ;;; Daemon/substituter protocol. ;;; +(define %prefer-fast-decompression? + ;; Whether to prefer fast decompression over good compression ratios. This + ;; serves in particular to choose between lzip (high compression ratio but + ;; low decompression throughput) and zstd (lower compression ratio but high + ;; decompression throughput). + #f) + +(define (call-with-cpu-usage-monitoring proc) + (let ((before (times))) + (proc) + (let ((after (times))) + (if (= (tms:clock after) (tms:clock before)) + 0 + (/ (- (tms:utime after) (tms:utime before)) + (- (tms:clock after) (tms:clock before)) + 1.))))) + +(define-syntax-rule (with-cpu-usage-monitoring exp ...) + "Evaluate EXP... Return its CPU usage as a fraction between 0 and 1." + (call-with-cpu-usage-monitoring (lambda () exp ...))) + (define (display-narinfo-data narinfo) "Write to the current output port the contents of NARINFO in the format expected by the daemon." @@ -269,7 +291,10 @@ expected by the daemon." (for-each (cute format #t "~a/~a~%" (%store-prefix) <>) (narinfo-references narinfo)) - (let-values (((uri compression file-size) (narinfo-best-uri narinfo))) + (let-values (((uri compression file-size) + (narinfo-best-uri narinfo + #:fast-decompression? + %prefer-fast-decompression?))) (format #t "~a\n~a\n" (or file-size 0) (or (narinfo-size narinfo) 0)))) @@ -288,12 +313,30 @@ authorized substitutes." (lambda (obj) (valid-narinfo? obj acl)))) + (define* (make-progress-reporter total #:key url) + (define done 0) + + (define (report-progress) + (erase-current-line (current-error-port)) ;erase current line + (force-output (current-error-port)) + (format (current-error-port) + (G_ "updating substitutes from '~a'... ~5,1f%") + url (* 100. (/ done total))) + (set! done (+ 1 done))) + + (progress-reporter + (start report-progress) + (report report-progress) + (stop (lambda () + (newline (current-error-port)))))) + (match (string-tokenize command) (("have" paths ..1) ;; Return the subset of PATHS available in CACHE-URLS. (let ((substitutable (lookup-narinfos/diverse cache-urls paths valid? - #:open-connection open-connection-for-uri/cached))) + #:open-connection open-connection-for-uri/cached + #:make-progress-reporter make-progress-reporter))) (for-each (lambda (narinfo) (format #t "~a~%" (narinfo-path narinfo))) substitutable) @@ -302,7 +345,8 @@ authorized substitutes." ;; Reply info about PATHS if it's in CACHE-URLS. (let ((substitutable (lookup-narinfos/diverse cache-urls paths valid? - #:open-connection open-connection-for-uri/cached))) + #:open-connection open-connection-for-uri/cached + #:make-progress-reporter make-progress-reporter))) (for-each display-narinfo-data substitutable) (newline))) (wtf @@ -358,6 +402,32 @@ server certificates." (drain-input socket) socket)))))))) +(define (call-with-cached-connection uri proc) + (let ((port (open-connection-for-uri/cached uri + #:verify-certificate? #f))) + (catch #t + (lambda () + (proc port)) + (lambda (key . args) + ;; If PORT was cached and the server closed the connection in the + ;; meantime, we get EPIPE. In that case, open a fresh connection + ;; and retry. We might also get 'bad-response or a similar + ;; exception from (web response) later on, once we've sent the + ;; request, or a ERROR/INVALID-SESSION from GnuTLS. + (if (or (and (eq? key 'system-error) + (= EPIPE (system-error-errno `(,key ,@args)))) + (and (eq? key 'gnutls-error) + (eq? (first args) error/invalid-session)) + (memq key '(bad-response bad-header bad-header-component))) + (proc (open-connection-for-uri/cached uri + #:verify-certificate? #f + #:fresh? #t)) + (apply throw key args)))))) + +(define-syntax-rule (with-cached-connection uri port exp ...) + "Bind PORT with EXP... to a socket connected to URI." + (call-with-cached-connection uri (lambda (port) exp ...))) + (define* (process-substitution store-item destination #:key cache-urls acl deduplicate? print-build-trace?) @@ -402,14 +472,11 @@ the current output port." (warning (G_ "while fetching ~a: server is somewhat slow~%") (uri->string uri)) (warning (G_ "try `--no-substitutes' if the problem persists~%"))) - (call-with-connection-error-handling - uri - (lambda () - (http-fetch uri #:text? #f - #:open-connection open-connection-for-uri/cached - #:keep-alive? #t - #:buffered? #f - #:verify-certificate? #f)))))) + (with-cached-connection uri port + (http-fetch uri #:text? #f + #:port port + #:keep-alive? #t + #:buffered? #f))))) (else (leave (G_ "unsupported substitute URI scheme: ~a~%") (uri->string uri))))) @@ -419,7 +486,9 @@ the current output port." store-item)) (let-values (((uri compression file-size) - (narinfo-best-uri narinfo))) + (narinfo-best-uri narinfo + #:fast-decompression? + %prefer-fast-decompression?))) (unless print-build-trace? (format (current-error-port) (G_ "Downloading ~a...~%") (uri->string uri))) @@ -457,11 +526,28 @@ the current output port." ((hashed get-hash) (open-hash-input-port algorithm input))) ;; Unpack the Nar at INPUT into DESTINATION. - (restore-file hashed destination - #:dump-file (if (and destination-in-store? - deduplicate?) - dump-file/deduplicate* - dump-file)) + (define cpu-usage + (with-cpu-usage-monitoring + (restore-file hashed destination + #:dump-file (if (and destination-in-store? + deduplicate?) + dump-file/deduplicate* + dump-file)))) + + ;; Create a hysteresis: depending on CPU usage, favor compression + ;; methods with faster decompression (like ztsd) or methods with better + ;; compression ratios (like lzip). This stems from the observation that + ;; substitution can be CPU-bound when high-speed networks are used: + ;; <https://lists.gnu.org/archive/html/guix-devel/2020-12/msg00177.html>. + ;; To simulate "slow" networking or changing conditions, run: + ;; sudo tc qdisc add dev eno1 root tbf rate 512kbit latency 50ms burst 1540 + ;; and then cancel with: + ;; sudo tc qdisc del dev eno1 root + (when (> cpu-usage .8) + (set! %prefer-fast-decompression? #t)) + (when (< cpu-usage .2) + (set! %prefer-fast-decompression? #f)) + (close-port hashed) (close-port input) @@ -696,6 +782,8 @@ if needed, as expected by the daemon's agent." ;;; Local Variables: ;;; eval: (put 'with-timeout 'scheme-indent-function 1) ;;; eval: (put 'with-redirected-error-port 'scheme-indent-function 0) +;;; eval: (put 'with-cached-connection 'scheme-indent-function 2) +;;; eval: (put 'call-with-cached-connection 'scheme-indent-function 1) ;;; End: ;;; substitute.scm ends here diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index e3cf99acc6..c226f08371 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -8,6 +8,7 @@ ;;; Copyright © 2020 Jan (janneke) Nieuwenhuizen <janneke@gnu.org> ;;; Copyright © 2020 Julien Lepiller <julien@lepiller.eu> ;;; Copyright © 2020 Efraim Flashner <efraim@flashner.co.il> +;;; Copyright © 2021 Brice Waegeneire <brice@waegenei.re> ;;; ;;; This file is part of GNU Guix. ;;; @@ -363,11 +364,14 @@ connection to the store." "Switch the system profile to the generation specified by SPEC, and re-install bootloader with a configuration file that uses the specified system generation as its default entry. STORE is an open connection to the store." - (let ((number (relative-generation-spec->number %system-profile spec))) + (let* ((number (relative-generation-spec->number %system-profile spec)) + (generation (generation-file-name %system-profile number)) + (activate (string-append generation "/activate"))) (if number (begin (reinstall-bootloader store number) - (switch-to-generation* %system-profile number)) + (switch-to-generation* %system-profile number) + (unless-file-not-found (primitive-load activate))) (leave (G_ "cannot switch to system generation '~a'~%") spec)))) (define* (system-bootloader-name #:optional (system %system-profile)) diff --git a/guix/scripts/time-machine.scm b/guix/scripts/time-machine.scm index 0d27414702..4aafd432e8 100644 --- a/guix/scripts/time-machine.scm +++ b/guix/scripts/time-machine.scm @@ -1,6 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2019 Konrad Hinsen <konrad.hinsen@fastmail.net> ;;; Copyright © 2019, 2020 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2021 Simon Tournier <zimon.toutoune@gmail.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -118,6 +119,10 @@ Execute COMMAND ARGS... in an older version of Guix.\n")) (let-values (((args command) (break (cut string=? "--" <>) args))) (let ((opts (parse-command-line args %options (list %default-options)))) + (when (assoc-ref opts 'argument) + (leave (G_ "~A: extraneous argument~%") + (assoc-ref opts 'argument))) + (match command (() opts) (("--") opts) diff --git a/guix/scripts/weather.scm b/guix/scripts/weather.scm index 9e94bff5a3..5164fe0494 100644 --- a/guix/scripts/weather.scm +++ b/guix/scripts/weather.scm @@ -117,8 +117,8 @@ values." (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-syntax-rule (let/time ((time result ... exp)) body ...) + (call-with-time (lambda () exp) (lambda (time result ...) body ...))) (define (histogram field proc seed lst) "Return an alist giving a histogram of all the values of FIELD for elements @@ -181,7 +181,12 @@ Return the coverage ratio, an exact number between 0 and 1." (format #t (G_ "looking for ~h store items on ~a...~%") (length items) server) - (let/time ((time narinfos (lookup-narinfos server items))) + (let/time ((time narinfos requests-made + (lookup-narinfos + server items + #:make-progress-reporter + (lambda* (total #:key url #:allow-other-keys) + (progress-reporter/bar total))))) (format #t "~a~%" server) (let ((obtained (length narinfos)) (requested (length items)) @@ -207,10 +212,11 @@ Return the coverage ratio, an exact number between 0 and 1." 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.)) + (when (> requests-made 0) + (format #t (G_ " ~,3h seconds per request (~,1h seconds in total)~%") + (/ time requests-made 1.) time) + (format #t (G_ " ~,1h requests per second~%") + (/ requests-made time 1.))) (guard (c ((http-get-error? c) (if (= 404 (http-get-error-code c)) |