Merge remote-tracking branch 'origin/master' into core-updates

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))