import: go: Add an option to use pinned versions.

The ability to pin versions is handy when having to deal to packages that
bootstrap themselves through a chain of former versions.  Not using pinned
versions in these case could introduce dependency cycles.

* guix/build-system/go.scm (guix)
(%go-version-rx): Rename to...
(%go-pseudo-version-rx): ... this.  Simplify the regular expression, which in
turns makes it more robust.
* guix/build-system/go.scm (go-version->git-ref): Adjust following the above
rename.
(go-pseudo-version?): New predicate.
(go-module-latest-version): Rename to ...
(go-module-version-string): ... this.  Rename goproxy-url argument to just
goproxy.  Add a VERSION keyword argument, update docstring and adjust to have
it used.
(go-module-available-versions): New procedure.
(%go.mod-require-directive-rx): Document regexp.
(parse-go.mod): Harmonize the way dependencies are recorded to a list of lists
rather than a list of pairs, as done for other importers.  Rewrite to directly pass
multiple values rather than a record object.  Filter the replaced modules in a
functional style.
(go-module->guix-package): Add docstring.
[version, pin-versions?]: New arguments.  Rename the GOPROXY-URL argument to
GOPROXY.  Adjust to the new returned value of fetch-go.mod, which is a string.
Fail when the provided version doesn't exist.  Return a list dependencies and
their versions when in pinned versions mode, else just the dependencies.
(go-module-recursive-import)[version, pin-versions?]: New arguments.
Honor the new arguments and guard against network errors.
* guix/scripts/import/go.scm (%default-options): Register a default value for
the goproxy argument.
(show-help): Document that a version can be specified.  Remove the --version
argument and add a --pin-versions argument.
(%options)[version]: Remove option.
[pin-versions]: Add option.
(guix-import-go): Adjust so the version provided from the module name is
honored, along the new pin-versions? argument.
* tests/go.scm: Adjust and add new tests.

3 files changed, 198 insertions, 135 deletions

diff --git a/guix/build-system/go.scm b/guix/build-system/go.scm
index 0e2c1cd2ee..8f55796e86 100644
--- a/guix/build-system/go.scm
+++ b/guix/build-system/go.scm
@@ -31,6 +31,7 @@
             go-build
             go-build-system
 
+            go-pseudo-version?
             go-version->git-ref))
 
 ;; Commentary:
@@ -40,17 +41,19 @@
 ;;
 ;; Code:
 
-(define %go-version-rx
+(define %go-pseudo-version-rx
+  ;; Match only the end of the version string; this is so that matching the
+  ;; more complex leading semantic version pattern is not required.
   (make-regexp (string-append
-                "(v?[0-9]\\.[0-9]\\.[0-9])" ;"v" prefix can be omitted in version prefix
-                "(-|-pre\\.0\\.|-0\\.)"     ;separator
-                "([0-9]{14})-"              ;timestamp
-                "([0-9A-Fa-f]{12})")))      ;commit hash
+                "([0-9]{14}-)"                 ;timestamp
+                "([0-9A-Fa-f]{12})"            ;commit hash
+                "(\\+incompatible)?$")))       ;optional +incompatible tag
 
 (define (go-version->git-ref version)
   "Parse VERSION, a \"pseudo-version\" as defined at
 <https://golang.org/ref/mod#pseudo-versions>, and extract the commit hash from
-it, defaulting to full VERSION if a pseudo-version pattern is not recognized."
+it, defaulting to full VERSION (stripped from the \"+incompatible\" suffix if
+present) if a pseudo-version pattern is not recognized."
   ;; A module version like v1.2.3 is introduced by tagging a revision in the
   ;; underlying source repository.  Untagged revisions can be referred to
   ;; using a "pseudo-version" like v0.0.0-yyyymmddhhmmss-abcdefabcdef, where
@@ -65,11 +68,16 @@ it, defaulting to full VERSION if a pseudo-version pattern is not recognized."
           (if (string-suffix? "+incompatible" version)
               (string-drop-right version 13)
               version))
-         (match (regexp-exec %go-version-rx version)))
+         (match (regexp-exec %go-pseudo-version-rx version)))
     (if match
-        (match:substring match 4)
+        (match:substring match 2)
         version)))
 
+(define (go-pseudo-version? version)
+  "True if VERSION is a Go pseudo-version, i.e., a version string made of a
+commit hash and its date rather than a proper release tag."
+  (regexp-exec %go-pseudo-version-rx version))
+
 (define %go-build-system-modules
   ;; Build-side modules imported and used by default.
   `((guix build go-build-system)
diff --git a/guix/import/go.scm b/guix/import/go.scm
index 8c8f20b109..ca2b9c6fa0 100644
--- a/guix/import/go.scm
+++ b/guix/import/go.scm
@@ -50,6 +50,7 @@
   #:use-module (srfi srfi-9)
   #:use-module (srfi srfi-11)
   #:use-module (srfi srfi-26)
+  #:use-module (srfi srfi-34)
   #:use-module (sxml match)
   #:use-module ((sxml xpath) #:renamer (lambda (s)
                                          (if (eq? 'filter s)
@@ -92,9 +93,7 @@
 ;;; assumption that there will be no collision.
 
 ;;; TODO list
-;;; - get correct hash in vcs->origin
-;;; - print partial result during recursive imports (need to catch
-;;;   exceptions)
+;;; - get correct hash in vcs->origin for Mercurial and Subversion
 
 ;;; Code:
 
@@ -121,12 +120,26 @@ https://godoc.org/golang.org/x/mod/module#hdr-Escaped_Paths)."
 (define (go.pkg.dev-info name)
   (http-fetch* (string-append "https://pkg.go.dev/" name)))
 
-(define (go-module-latest-version goproxy-url module-path)
-  "Fetch the version number of the latest version for MODULE-PATH from the
-given GOPROXY-URL server."
-  (assoc-ref (json-fetch* (format #f "~a/~a/@latest" goproxy-url
-                                  (go-path-escape module-path)))
-             "Version"))
+(define* (go-module-version-string goproxy name #:key version)
+  "Fetch the version string of the latest version for NAME from the given
+GOPROXY server, or for VERSION when specified."
+  (let ((file (if version
+                  (string-append "@v/" version ".info")
+                  "@latest")))
+    (assoc-ref (json-fetch* (format #f "~a/~a/~a"
+                                    goproxy (go-path-escape name) file))
+               "Version")))
+
+(define* (go-module-available-versions goproxy name)
+  "Retrieve the available versions for a given module from the module proxy.
+Versions are being returned **unordered** and may contain different versioning
+styles for the same package."
+  (let* ((url (string-append goproxy "/" (go-path-escape name) "/@v/list"))
+         (body (http-fetch* url))
+         (versions (remove string-null? (string-split body #\newline))))
+    (if (null? versions)
+        (list (go-module-version-string goproxy name)) ;latest version
+        versions)))
 
 (define (go-package-licenses name)
   "Retrieve the list of licenses that apply to NAME, a Go package or module
@@ -238,119 +251,119 @@ and VERSION and return an input port."
   ;; the end.
   (make-regexp
    (string-append
-    "^[[:blank:]]*"
-    "([^[:blank:]]+)[[:blank:]]+([^[:blank:]]+)"
-    "([[:blank:]]+//.*)?")))
+    "^[[:blank:]]*([^[:blank:]]+)[[:blank:]]+" ;the module path
+    "([^[:blank:]]+)"                          ;the version
+    "([[:blank:]]+//.*)?")))                   ;an optional comment
 
 (define %go.mod-replace-directive-rx
   ;; ReplaceSpec = ModulePath [ Version ] "=>" FilePath newline
   ;;             | ModulePath [ Version ] "=>" ModulePath Version newline .
   (make-regexp
    (string-append
-    "([^[:blank:]]+)([[:blank:]]+([^[:blank:]]+))?"
-    "[[:blank:]]+" "=>" "[[:blank:]]+"
-    "([^[:blank:]]+)([[:blank:]]+([^[:blank:]]+))?")))
+    "([^[:blank:]]+)"                   ;the module path
+    "([[:blank:]]+([^[:blank:]]+))?"    ;optional version
+    "[[:blank:]]+=>[[:blank:]]+"
+    "([^[:blank:]]+)"                   ;the file or module path
+    "([[:blank:]]+([^[:blank:]]+))?"))) ;the version (if a module path)
 
 (define (parse-go.mod content)
   "Parse the go.mod file CONTENT, returning a list of requirements."
-  (define-record-type <results>
-    (make-results requirements replacements)
-    results?
-    (requirements results-requirements)
-    (replacements results-replacements))
   ;; We parse only a subset of https://golang.org/ref/mod#go-mod-file-grammar
   ;; which we think necessary for our use case.
-  (define (toplevel results)
-    "Main parser, RESULTS is a pair of alist serving as accumulator for
-     all encountered requirements and replacements."
+  (define (toplevel requirements replaced)
+    "This is the main parser.  The results are accumulated in THE REQUIREMENTS
+and REPLACED lists."
     (let ((line (read-line)))
       (cond
        ((eof-object? line)
         ;; parsing ended, give back the result
-        results)
+        (values requirements replaced))
        ((string=? line "require (")
         ;; a require block begins, delegate parsing to IN-REQUIRE
-        (in-require results))
+        (in-require requirements replaced))
        ((string=? line "replace (")
         ;; a replace block begins, delegate parsing to IN-REPLACE
-        (in-replace results))
+        (in-replace requirements replaced))
        ((string-prefix? "require " line)
-        ;; a standalone require directive
-        (let* ((stripped-line (string-drop line 8))
-               (new-results (require-directive results stripped-line)))
-          (toplevel new-results)))
+        ;; a require directive by itself
+        (let* ((stripped-line (string-drop line 8)))
+          (call-with-values
+              (lambda ()
+                (require-directive requirements replaced stripped-line))
+            toplevel)))
        ((string-prefix? "replace " line)
-        ;; a standalone replace directive
-        (let* ((stripped-line (string-drop line 8))
-               (new-results (replace-directive results stripped-line)))
-          (toplevel new-results)))
+        ;; a replace directive by itself
+        (let* ((stripped-line (string-drop line 8)))
+          (call-with-values
+              (lambda ()
+                (replace-directive requirements replaced stripped-line))
+            toplevel)))
        (#t
         ;; unrecognised line, ignore silently
-        (toplevel results)))))
+        (toplevel requirements replaced)))))
 
-  (define (in-require results)
+  (define (in-require requirements replaced)
     (let ((line (read-line)))
       (cond
        ((eof-object? line)
         ;; this should never happen here but we ignore silently
-        results)
+        (values requirements replaced))
        ((string=? line ")")
         ;; end of block, coming back to toplevel
-        (toplevel results))
+        (toplevel requirements replaced))
        (#t
-        (in-require (require-directive results line))))))
+        (call-with-values (lambda ()
+                            (require-directive requirements replaced line))
+          in-require)))))
 
-  (define (in-replace results)
+  (define (in-replace requirements replaced)
     (let ((line (read-line)))
       (cond
        ((eof-object? line)
         ;; this should never happen here but we ignore silently
-        results)
+        (values requirements replaced))
        ((string=? line ")")
         ;; end of block, coming back to toplevel
-        (toplevel results))
+        (toplevel requirements replaced))
        (#t
-        (in-replace (replace-directive results line))))))
-
-  (define (replace-directive results line)
-    "Extract replaced modules and new requirements from replace directive
-    in LINE and add to RESULTS."
-    (match results
-      (($ <results> requirements replaced)
-       (let* ((rx-match (regexp-exec %go.mod-replace-directive-rx line))
-              (module-path (match:substring rx-match 1))
-              (version (match:substring rx-match 3))
-              (new-module-path (match:substring rx-match 4))
-              (new-version (match:substring rx-match 6))
-              (new-replaced (alist-cons module-path version replaced))
-              (new-requirements
-               (if (string-match "^\\.?\\./" new-module-path)
-                   requirements
-                   (alist-cons new-module-path new-version requirements))))
-         (make-results new-requirements new-replaced)))))
-  (define (require-directive results line)
-    "Extract requirement from LINE and add it to RESULTS."
+        (call-with-values (lambda ()
+                            (replace-directive requirements replaced line))
+          in-replace)))))
+
+  (define (replace-directive requirements replaced line)
+    "Extract replaced modules and new requirements from the replace directive
+in LINE and add them to the REQUIREMENTS and REPLACED lists."
+    (let* ((rx-match (regexp-exec %go.mod-replace-directive-rx line))
+           (module-path (match:substring rx-match 1))
+           (version (match:substring rx-match 3))
+           (new-module-path (match:substring rx-match 4))
+           (new-version (match:substring rx-match 6))
+           (new-replaced (cons (list module-path version) replaced))
+           (new-requirements
+            (if (string-match "^\\.?\\./" new-module-path)
+                requirements
+                (cons (list new-module-path new-version) requirements))))
+      (values new-requirements new-replaced)))
+
+  (define (require-directive requirements replaced line)
+    "Extract requirement from LINE and augment the REQUIREMENTS and REPLACED
+lists."
     (let* ((rx-match (regexp-exec %go.mod-require-directive-rx line))
            (module-path (match:substring rx-match 1))
-           ;; we saw double-quoted string in the wild without escape
-           ;; sequences so we just trim the quotes
+           ;; Double-quoted strings were seen in the wild without escape
+           ;; sequences; trim the quotes to be on the safe side.
            (module-path (string-trim-both module-path #\"))
            (version (match:substring rx-match 2)))
-      (match results
-        (($ <results> requirements replaced)
-         (make-results (alist-cons module-path version requirements) replaced)))))
-
-  (let ((results (with-input-from-string content
-                   (lambda _
-                     (toplevel (make-results '() '()))))))
-    (match results
-      (($ <results> requirements replaced)
-       ;; At last we remove replaced modules from the requirements list
-       (fold
-        (lambda (replacedelem requirements)
-          (alist-delete! (car replacedelem) requirements))
-        requirements
-        replaced)))))
+      (values (cons (list module-path version) requirements) replaced)))
+
+  (with-input-from-string content
+    (lambda ()
+      (receive (requirements replaced)
+          (toplevel '() '())
+        ;; At last remove the replaced modules from the requirements list.
+        (remove (lambda (r)
+                  (assoc (car r) replaced))
+                requirements)))))
 
 ;; Prevent inlining of this procedure, which is accessed by unit tests.
 (set! parse-go.mod parse-go.mod)
@@ -553,17 +566,32 @@ control system is being used."
                          vcs-type vcs-repo-url)))))
 
 (define* (go-module->guix-package module-path #:key
-                                  (goproxy-url "https://proxy.golang.org"))
-  (let* ((latest-version (go-module-latest-version goproxy-url module-path))
-         (content (fetch-go.mod goproxy-url module-path latest-version))
-         (dependencies (map car (parse-go.mod content)))
+                                  (goproxy "https://proxy.golang.org")
+                                  version
+                                  pin-versions?)
+  "Return the package S-expression corresponding to MODULE-PATH at VERSION, a Go package.
+The meta-data is fetched from the GOPROXY server and https://pkg.go.dev/.
+When VERSION is unspecified, the latest version available is used."
+  (let* ((available-versions (go-module-available-versions goproxy module-path))
+         (version* (or version
+                       (go-module-version-string goproxy module-path))) ;latest
+         ;; Pseudo-versions do not appear in the versions list; skip the
+         ;; following check.
+         (_ (unless (or (go-pseudo-version? version*)
+                        (member version* available-versions))
+              (error (format #f "error: version ~s is not available
+hint: use one of the following available versions ~a\n"
+                             version* available-versions))))
+         (content (fetch-go.mod goproxy module-path version*))
+         (dependencies+versions (parse-go.mod content))
+         (dependencies (map car dependencies+versions))
          (guix-name (go-module->guix-package-name module-path))
          (root-module-path (module-path->repository-root module-path))
          ;; The VCS type and URL are not included in goproxy information. For
          ;; this we need to fetch it from the official module page.
          (meta-data (fetch-module-meta-data root-module-path))
          (vcs-type (module-meta-vcs meta-data))
-         (vcs-repo-url (module-meta-data-repo-url meta-data goproxy-url))
+         (vcs-repo-url (module-meta-data-repo-url meta-data goproxy))
          (synopsis (go-package-synopsis root-module-path))
          (description (go-package-description module-path))
          (licenses (go-package-licenses module-path)))
@@ -571,14 +599,14 @@ control system is being used."
      `(package
         (name ,guix-name)
         ;; Elide the "v" prefix Go uses
-        (version ,(string-trim latest-version #\v))
+        (version ,(string-trim version* #\v))
         (source
-         ,(vcs->origin vcs-type vcs-repo-url latest-version))
+         ,(vcs->origin vcs-type vcs-repo-url version*))
         (build-system go-build-system)
         (arguments
          '(#:import-path ,root-module-path))
-        ,@(maybe-propagated-inputs
-           (map go-module->guix-package-name dependencies))
+        ,@(maybe-propagated-inputs (map go-module->guix-package-name
+                                        dependencies))
         (home-page ,(format #f "https://~a" root-module-path))
         (synopsis ,synopsis)
         (description ,(and=> description beautify-description))
@@ -588,16 +616,37 @@ control system is being used."
                      license)
                     ((license ...)      ;a list of licenses
                      `(list ,@license)))))
-     dependencies)))
+     (if pin-versions?
+         dependencies+versions
+         dependencies))))
 
 (define go-module->guix-package* (memoize go-module->guix-package))
 
 (define* (go-module-recursive-import package-name
-                                     #:key (goproxy-url "https://proxy.golang.org"))
+                                     #:key (goproxy "https://proxy.golang.org")
+                                     version
+                                     pin-versions?)
+
   (recursive-import
    package-name
-   #:repo->guix-package (lambda* (name . _)
-                          (go-module->guix-package*
-                           name
-                           #:goproxy-url goproxy-url))
-   #:guix-name go-module->guix-package-name))
+   #:repo->guix-package
+   (lambda* (name #:key version repo)
+     ;; Disable output buffering so that the following warning gets printed
+     ;; consistently.
+     (setvbuf (current-error-port) 'none)
+     (guard (c ((http-get-error? c)
+                (warning (G_ "Failed to import package ~s.
+reason: ~s could not be fetched: HTTP error ~a (~s).
+This package and its dependencies won't be imported.~%")
+                         name
+                         (uri->string (http-get-error-uri c))
+                         (http-get-error-code c)
+                         (http-get-error-reason c))
+                (values '() '())))
+       (receive (package-sexp dependencies)
+           (go-module->guix-package* name #:goproxy goproxy
+                                     #:version version
+                                     #:pin-versions? pin-versions?)
+         (values package-sexp dependencies))))
+   #:guix-name go-module->guix-package-name
+   #:version version))
diff --git a/guix/scripts/import/go.scm b/guix/scripts/import/go.scm
index afdba4e8f1..33d2470ce1 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.
 ;;;
@@ -27,28 +28,30 @@
   #: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 +61,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 +69,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.
 ;;;
@@ -93,25 +96,28 @@ Import and convert the Go module for PACKAGE-PATH.\n"))
                              (_ #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)))
+      ((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 (match-lambda
+                      ((and ('package ('name name) . rest) pkg)
+                       `(define-public ,(string->symbol name)
+                          ,pkg))
+                      (_ #f))
+                    (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))
+                 sexp)))))
       (()
        (leave (G_ "too few arguments~%")))
       ((many ...)