Merge remote-tracking branch 'upstream/master' into staging

4 files changed, 130 insertions, 133 deletions

diff --git a/guix/scripts/import.scm b/guix/scripts/import.scm
index 1d2b45d942..98554ef79b 100644
--- a/guix/scripts/import.scm
+++ b/guix/scripts/import.scm
@@ -119,7 +119,8 @@ Run IMPORTER with ARGS.\n"))
                                             (current-output-port))))))
            (match (apply (resolve-importer importer) args)
              ((and expr (or ('package _ ...)
-                            ('let _ ...)))
+                            ('let _ ...)
+                            ('define-public _ ...)))
               (print expr))
              ((? list? expressions)
               (for-each (lambda (expr)
diff --git a/guix/scripts/import/go.scm b/guix/scripts/import/go.scm
index afdba4e8f1..04b07f80cc 100644
--- a/guix/scripts/import/go.scm
+++ b/guix/scripts/import/go.scm
@@ -1,5 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2020 Katherine Cox-Buday <cox.katherine.e@gmail.com>
+;;; Copyright © 2020 Katherine Cox-Buday <cox.katherine.e@gmail.com>
+;;; Copyright © 2021 Maxim Cournoyer <maxim.cournoyer@gmail.com>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -21,34 +22,38 @@
   #:use-module (guix utils)
   #:use-module (guix scripts)
   #:use-module (guix import go)
+  #:use-module (guix import utils)
   #:use-module (guix scripts import)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-11)
+  #:use-module (srfi srfi-26)
   #:use-module (srfi srfi-37)
   #:use-module (ice-9 match)
   #:use-module (ice-9 format)
+  #:use-module (ice-9 receive)
   #:export (guix-import-go))
 
-
+
 ;;;
 ;;; Command-line options.
 ;;;
 
 (define %default-options
-  '())
+  '((goproxy . "https://proxy.golang.org")))
 
 (define (show-help)
-  (display (G_ "Usage: guix import go PACKAGE-PATH
-Import and convert the Go module for PACKAGE-PATH.\n"))
+  (display (G_ "Usage: guix import go PACKAGE-PATH[@VERSION]
+Import and convert the Go module for PACKAGE-PATH.  Optionally, a version
+can be specified after the arobas (@) character.\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"))
+  -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"))
+  (display (G_ "
+  --pin-versions         use the exact versions of a module's dependencies"))
   (newline)
   (show-bug-report-information))
 
@@ -58,9 +63,6 @@ Import and convert the Go module for PACKAGE-PATH.\n"))
                  (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)))
@@ -69,9 +71,12 @@ Import and convert the Go module for PACKAGE-PATH.\n"))
                    (alist-cons 'goproxy
                                (string->symbol arg)
                                (alist-delete 'goproxy result))))
+         (option '("pin-versions") #f #f
+                 (lambda (opt name arg result)
+                   (alist-cons 'pin-versions? #t result)))
          %standard-import-options))
 
-
+
 ;;;
 ;;; Entry point.
 ;;;
@@ -91,27 +96,31 @@ Import and convert the Go module for PACKAGE-PATH.\n"))
                              (('argument . value)
                               value)
                              (_ #f))
-                           (reverse opts))))
+                           (reverse opts)))
+         ;; Append the full version to the package symbol name when using
+         ;; pinned versions.
+         (package->definition* (if (assoc-ref opts 'pin-versions?)
+                                   (cut package->definition <> 'full)
+                                   package->definition)))
     (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)))
+      ((spec)                         ;e.g., github.com/golang/protobuf@v1.3.1
+       (receive (name version)
+           (package-name->name+version spec)
+         (let ((arguments (list name
+                                #:goproxy (assoc-ref opts 'goproxy)
+                                #:version version
+                                #:pin-versions?
+                                (assoc-ref opts 'pin-versions?))))
+           (if (assoc-ref opts 'recursive)
+               ;; Recursive import.
+               (map package->definition*
+                    (apply go-module-recursive-import arguments))
+               ;; Single import.
+               (let ((sexp (apply go-module->guix-package arguments)))
+                 (unless sexp
+                   (leave (G_ "failed to download meta-data for module '~a'~%")
+                          module-name))
+                 (package->definition* sexp))))))
       (()
        (leave (G_ "too few arguments~%")))
       ((many ...)
diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm
index 79eaabd8fd..48309f9b3a 100755
--- a/guix/scripts/substitute.scm
+++ b/guix/scripts/substitute.scm
@@ -63,7 +63,7 @@
   #:use-module (web uri)
   #:use-module (guix http-client)
   #:export (%allow-unauthenticated-substitutes?
-            %error-to-file-descriptor-4?
+            %reply-file-descriptor
 
             substitute-urls
             guix-substitute))
@@ -279,29 +279,29 @@ Internal tool to substitute a pre-built binary to a local build.\n"))
   "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."
-  (format #t "~a\n~a\n~a\n"
+(define (display-narinfo-data port narinfo)
+  "Write to PORT the contents of NARINFO in the format expected by the
+daemon."
+  (format port "~a\n~a\n~a\n"
           (narinfo-path narinfo)
           (or (and=> (narinfo-deriver narinfo)
                      (cute string-append (%store-prefix) "/" <>))
               "")
           (length (narinfo-references narinfo)))
-  (for-each (cute format #t "~a/~a~%" (%store-prefix) <>)
+  (for-each (cute format port "~a/~a~%" (%store-prefix) <>)
             (narinfo-references narinfo))
 
   (let-values (((uri compression file-size)
                 (narinfo-best-uri narinfo
                                   #:fast-decompression?
                                   %prefer-fast-decompression?)))
-    (format #t "~a\n~a\n"
+    (format port "~a\n~a\n"
             (or file-size 0)
             (or (narinfo-size narinfo) 0))))
 
-(define* (process-query command
+(define* (process-query port command
                         #:key cache-urls acl)
-  "Reply to COMMAND, a query as written by the daemon to this process's
+  "Reply on PORT to COMMAND, a query as written by the daemon to this process's
 standard input.  Use ACL as the access-control list against which to check
 authorized substitutes."
   (define valid?
@@ -338,17 +338,17 @@ authorized substitutes."
                            #:open-connection open-connection-for-uri/cached
                            #:make-progress-reporter make-progress-reporter)))
        (for-each (lambda (narinfo)
-                   (format #t "~a~%" (narinfo-path narinfo)))
+                   (format port "~a~%" (narinfo-path narinfo)))
                  substitutable)
-       (newline)))
+       (newline port)))
     (("info" paths ..1)
      ;; 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
                            #:make-progress-reporter make-progress-reporter)))
-       (for-each display-narinfo-data substitutable)
-       (newline)))
+       (for-each (cut display-narinfo-data port <>) substitutable)
+       (newline port)))
     (wtf
      (error "unknown `--query' command" wtf))))
 
@@ -428,14 +428,14 @@ server certificates."
   "Bind PORT with EXP... to a socket connected to URI."
   (call-with-cached-connection uri (lambda (port) exp ...)))
 
-(define* (process-substitution store-item destination
+(define* (process-substitution port store-item destination
                                #:key cache-urls acl
                                deduplicate? print-build-trace?)
   "Substitute STORE-ITEM (a store file name) from CACHE-URLS, and write it to
 DESTINATION as a nar file.  Verify the substitute against ACL, and verify its
 hash against what appears in the narinfo.  When DEDUPLICATE? is true, and if
-DESTINATION is in the store, deduplicate its files.  Print a status line on
-the current output port."
+DESTINATION is in the store, deduplicate its files.  Print a status line to
+PORT."
   (define narinfo
     (lookup-narinfo cache-urls store-item
                     (if (%allow-unauthenticated-substitutes?)
@@ -565,10 +565,10 @@ the current output port."
       (let ((actual (get-hash)))
         (if (bytevector=? actual expected)
             ;; Tell the daemon that we're done.
-            (format (current-output-port) "success ~a ~a~%"
+            (format port "success ~a ~a~%"
                     (narinfo-hash narinfo) (narinfo-size narinfo))
             ;; The actual data has a different hash than that in NARINFO.
-            (format (current-output-port) "hash-mismatch ~a ~a ~a~%"
+            (format port "hash-mismatch ~a ~a ~a~%"
                     (hash-algorithm-name algorithm)
                     (bytevector->nix-base32-string expected)
                     (bytevector->nix-base32-string actual)))))))
@@ -682,28 +682,10 @@ default value."
   (unless (string->uri uri)
     (leave (G_ "~a: invalid URI~%") uri)))
 
-(define %error-to-file-descriptor-4?
-  ;; Whether to direct 'current-error-port' to file descriptor 4 like
-  ;; 'guix-daemon' expects.
-  (make-parameter #t))
-
-;; The daemon's agent code opens file descriptor 4 for us and this is where
-;; stderr should go.
-(define-syntax-rule (with-redirected-error-port exp ...)
-  "Evaluate EXP... with the current error port redirected to file descriptor 4
-if needed, as expected by the daemon's agent."
-  (let ((thunk (lambda () exp ...)))
-    (if (%error-to-file-descriptor-4?)
-        (parameterize ((current-error-port (fdopen 4 "wl")))
-          ;; Redirect diagnostics to file descriptor 4 as well.
-          (guix-warning-port (current-error-port))
-
-          ;; 'with-continuation-barrier' captures the initial value of
-          ;; 'current-error-port' to report backtraces in case of uncaught
-          ;; exceptions.  Without it, backtraces would be printed to FD 2,
-          ;; thereby confusing the daemon.
-          (with-continuation-barrier thunk))
-        (thunk))))
+(define %reply-file-descriptor
+  ;; The file descriptor where replies to the daemon must be sent, or #f to
+  ;; use the current output port instead.
+  (make-parameter 4))
 
 (define-command (guix-substitute . args)
   (category internal)
@@ -719,68 +701,73 @@ if needed, as expected by the daemon's agent."
   (define deduplicate?
     (find-daemon-option "deduplicate"))
 
-  (with-redirected-error-port
-    (mkdir-p %narinfo-cache-directory)
-    (maybe-remove-expired-cache-entries %narinfo-cache-directory
-                                        cached-narinfo-files
-                                        #:entry-expiration
-                                        cached-narinfo-expiration-time
-                                        #:cleanup-period
-                                        %narinfo-expired-cache-entry-removal-delay)
-    (check-acl-initialized)
+  (define reply-port
+    ;; Port used to reply to the daemon.
+    (if (%reply-file-descriptor)
+        (fdopen (%reply-file-descriptor) "wl")
+        (current-output-port)))
 
-    ;; Sanity-check SUBSTITUTE-URLS so we can provide a meaningful error
-    ;; message.
-    (for-each validate-uri (substitute-urls))
+  (mkdir-p %narinfo-cache-directory)
+  (maybe-remove-expired-cache-entries %narinfo-cache-directory
+                                      cached-narinfo-files
+                                      #:entry-expiration
+                                      cached-narinfo-expiration-time
+                                      #:cleanup-period
+                                      %narinfo-expired-cache-entry-removal-delay)
+  (check-acl-initialized)
 
-    ;; Attempt to install the client's locale so that messages are suitably
-    ;; translated.  LC_CTYPE must be a UTF-8 locale; it's the case by default
-    ;; so don't change it.
-    (match (or (find-daemon-option "untrusted-locale")
-               (find-daemon-option "locale"))
-      (#f     #f)
-      (locale (false-if-exception (setlocale LC_MESSAGES locale))))
+  ;; Sanity-check SUBSTITUTE-URLS so we can provide a meaningful error
+  ;; message.
+  (for-each validate-uri (substitute-urls))
 
-    (catch 'system-error
-      (lambda ()
-        (set-thread-name "guix substitute"))
-      (const #t))                                 ;GNU/Hurd lacks 'prctl'
+  ;; Attempt to install the client's locale so that messages are suitably
+  ;; translated.  LC_CTYPE must be a UTF-8 locale; it's the case by default
+  ;; so don't change it.
+  (match (or (find-daemon-option "untrusted-locale")
+             (find-daemon-option "locale"))
+    (#f     #f)
+    (locale (false-if-exception (setlocale LC_MESSAGES locale))))
 
-    (with-networking
-     (with-error-handling                         ; for signature errors
-       (match args
-         (("--query")
-          (let ((acl (current-acl)))
-            (let loop ((command (read-line)))
-              (or (eof-object? command)
-                  (begin
-                    (process-query command
-                                   #:cache-urls (substitute-urls)
-                                   #:acl acl)
-                    (loop (read-line)))))))
-         (("--substitute")
-          ;; Download STORE-PATH and store it as a Nar in file DESTINATION.
-          ;; Specify the number of columns of the terminal so the progress
-          ;; report displays nicely.
-          (parameterize ((current-terminal-columns (client-terminal-columns)))
-            (let loop ()
-              (match (read-line)
-                ((? eof-object?)
-                 #t)
-                ((= string-tokenize ("substitute" store-path destination))
-                 (process-substitution store-path destination
-                                       #:cache-urls (substitute-urls)
-                                       #:acl (current-acl)
-                                       #:deduplicate? deduplicate?
-                                       #:print-build-trace?
-                                       print-build-trace?)
-                 (loop))))))
-         ((or ("-V") ("--version"))
-          (show-version-and-exit "guix substitute"))
-         (("--help")
-          (show-help))
-         (opts
-          (leave (G_ "~a: unrecognized options~%") opts)))))))
+  (catch 'system-error
+    (lambda ()
+      (set-thread-name "guix substitute"))
+    (const #t))                                   ;GNU/Hurd lacks 'prctl'
+
+  (with-networking
+   (with-error-handling                           ; for signature errors
+     (match args
+       (("--query")
+        (let ((acl (current-acl)))
+          (let loop ((command (read-line)))
+            (or (eof-object? command)
+                (begin
+                  (process-query reply-port command
+                                 #:cache-urls (substitute-urls)
+                                 #:acl acl)
+                  (loop (read-line)))))))
+       (("--substitute")
+        ;; Download STORE-PATH and store it as a Nar in file DESTINATION.
+        ;; Specify the number of columns of the terminal so the progress
+        ;; report displays nicely.
+        (parameterize ((current-terminal-columns (client-terminal-columns)))
+          (let loop ()
+            (match (read-line)
+              ((? eof-object?)
+               #t)
+              ((= string-tokenize ("substitute" store-path destination))
+               (process-substitution reply-port store-path destination
+                                     #:cache-urls (substitute-urls)
+                                     #:acl (current-acl)
+                                     #:deduplicate? deduplicate?
+                                     #:print-build-trace?
+                                     print-build-trace?)
+               (loop))))))
+       ((or ("-V") ("--version"))
+        (show-version-and-exit "guix substitute"))
+       (("--help")
+        (show-help))
+       (opts
+        (leave (G_ "~a: unrecognized options~%") opts))))))
 
 ;;; Local Variables:
 ;;; eval: (put 'with-timeout 'scheme-indent-function 1)
diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm
index c226f08371..0a051ee4e3 100644
--- a/guix/scripts/system.scm
+++ b/guix/scripts/system.scm
@@ -1145,7 +1145,7 @@ Some ACTIONS support additional ARGS.\n"))
   "Return the verbosity level based on OPTS, the alist of parsed options."
   (or (assoc-ref opts 'verbosity)
       (if (eq? (assoc-ref opts 'action) 'build)
-          2 1)))
+          3 1)))
 
 
 ;;;