;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2020 Katherine Cox-Buday <cox.katherine.e@gmail.com>
;;; Copyright © 2020 Helio Machado <0x2b3bfa0+guix@googlemail.com>
;;; Copyright © 2021 François Joulaud <francois.joulaud@radiofrance.com>
;;; Copyright © 2021 Maxim Cournoyer <maxim.cournoyer@gmail.com>
;;; Copyright © 2021 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz>
;;;
;;; 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 import go)
#:use-module (guix build-system go)
#:use-module (guix git)
#:use-module (guix i18n)
#:use-module (guix diagnostics)
#:use-module (guix import utils)
#:use-module (guix import json)
#:use-module (guix packages)
#:use-module ((guix utils) #:select (string-replace-substring))
#:use-module (guix http-client)
#:use-module ((guix licenses) #:prefix license:)
#:use-module (guix memoization)
#:autoload (htmlprag) (html->sxml) ;from Guile-Lib
#:autoload (guix git) (update-cached-checkout)
#:autoload (gcrypt hash) (open-hash-port hash-algorithm sha256)
#:autoload (guix serialization) (write-file)
#:autoload (guix base32) (bytevector->nix-base32-string)
#:autoload (guix build utils) (mkdir-p)
#:use-module (ice-9 match)
#:use-module (ice-9 rdelim)
#:use-module (ice-9 receive)
#:use-module (ice-9 regex)
#:use-module (ice-9 textual-ports)
#:use-module ((rnrs io ports) #:select (call-with-port))
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-2)
#: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)
'xfilter
s)))
#:use-module (web client)
#:use-module (web response)
#:use-module (web uri)
#:export (go-module->guix-package
go-module-recursive-import))
;;; Commentary:
;;;
;;; (guix import go) attempts to make it easier to create Guix package
;;; declarations for Go modules.
;;;
;;; Modules in Go are a "collection of related Go packages" which are "the
;;; unit of source code interchange and versioning". Modules are generally
;;; hosted in a repository.
;;;
;;; At this point it should handle correctly modules which have only Go
;;; dependencies and are accessible from proxy.golang.org (or configured via
;;; GOPROXY).
;;;
;;; We want it to work more or less this way:
;;; - get latest version for the module from GOPROXY
;;; - infer VCS root repo from which we will check-out source by
;;; + recognising known patterns (like github.com)
;;; + or recognizing .vcs suffix
;;; + or parsing meta tag in HTML served at the URL
;;; + or (TODO) if nothing else works by using zip file served by GOPROXY
;;; - get go.mod from GOPROXY (which is able to synthetize one if needed)
;;; - extract list of dependencies from this go.mod
;;;
;;; The Go module paths are translated to a Guix package name under the
;;; assumption that there will be no collision.
;;; TODO list
;;; - get correct hash in vcs->origin for Mercurial and Subversion
;;; Code:
(define http-fetch*
;; Like http-fetch, but memoized and returning the body as a string.
(memoize (lambda args
(call-with-port (apply http-fetch args) get-string-all))))
(define json-fetch*
(memoize json-fetch))
(define (go-path-escape path)
"Escape a module path by replacing every uppercase letter with an
exclamation mark followed with its lowercase equivalent, as per the module
Escaped Paths specification (see:
https://godoc.org/golang.org/x/mod/module#hdr-Escaped_Paths)."
(define (escape occurrence)
(string-append "!" (string-downcase (match:substring occurrence))))
(regexp-substitute/global #f "[A-Z]" path 'pre escape 'post))
;; Prevent inlining of this procedure, which is accessed by unit tests.
(set! go-path-escape go-path-escape)
(define (go.pkg.dev-info name)
(http-fetch* (string-append "https://pkg.go.dev/" name)))
(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
name (e.g. \"github.com/golang/protobuf/proto\")."
(let* ((body (go.pkg.dev-info (string-append name "?tab=licenses")))
;; Extract the text contained in a h2 child node of any
;; element marked with a "License" class attribute.
(select (sxpath `(// (* (@ (equal? (class "License"))))
h2 // *text*))))
(select (html->sxml body #:strict? #t))))
(define (sxml->texi sxml-node)
"A very basic SXML to Texinfo converter which attempts to preserve HTML
formatting and links as text."
(sxml-match sxml-node
((strong ,text)
(format #f "@strong{~a}" text))
((a (@ (href ,url)) ,text)
(format #f "@url{~a,~a}" url text))
((code ,text)
(format #f "@code{~a}" text))
(,something-else something-else)))
(define (go-package-description name)
"Retrieve a short description for NAME, a Go package name,
e.g. \"google.golang.org/protobuf/proto\"."
(let* ((body (go.pkg.dev-info name))
(sxml (html->sxml body #:strict? #t))
(overview ((sxpath
`(//
(* (@ (equal? (class "Documentation-overview"))))
(p 1))) sxml))
;; Sometimes, the first paragraph just contains images/links that
;; has only "\n" for text. The following filter is designed to
;; omit it.
(contains-text? (lambda (node)
(remove string-null?
(map string-trim-both
(filter (node-typeof? '*text*)
(cdr node))))))
(select-content (sxpath
`(//
(* (@ (equal? (class "UnitReadme-content"))))
div // p ,(xfilter contains-text?))))
;; Fall-back to use content; this is less desirable as it is more
;; verbose, but not every page has an overview.
(description (if (not (null? overview))
overview
(select-content sxml)))
(description* (and (not (null? description))
(first description))))
(match description*
(() #f) ;nothing selected
((p elements ...)
(apply string-append (filter string? (map sxml->texi elements)))))))
(define (go-package-synopsis module-name)
"Retrieve a short synopsis for a Go module named MODULE-NAME,
e.g. \"google.golang.org/protobuf\". The data is scraped from
the https://pkg.go.dev/ web site."
;; Note: Only the *module* (rather than package) page has the README title
;; used as a synopsis on the https://pkg.go.dev web site.
(let* ((url (string-append "https://pkg.go.dev/" module-name))
(body (http-fetch* url))
;; Extract the text contained in a h2 child node of any
;; element marked with a "License" class attribute.
(select-title (sxpath
`(// (div (@ (equal? (class "UnitReadme-content"))))
// h3 *text*))))
(match (select-title (html->sxml body #:strict? #t))
(() #f) ;nothing selected
((title more ...) ;title is the first string of the list
(string-trim-both title)))))
(define (list->licenses licenses)
"Given a list of LICENSES mostly following the SPDX conventions, return the
corresponding Guix license or 'unknown-license!"
(filter-map (lambda (license)
(and (not (string-null? license))
(not (any (cut string=? <> license)
'("AND" "OR" "WITH")))
;; Adjust the license names scraped from
;; https://pkg.go.dev to an equivalent SPDX identifier,
;; if they differ (see: https://github.com/golang/pkgsite
;; /internal/licenses/licenses.go#L174).
(or (spdx-string->license
(match license
("BlueOak-1.0" "BlueOak-1.0.0")
("BSD-0-Clause" "0BSD")
("BSD-2-Clause" "BSD-2-Clause-FreeBSD")
("GPL2" "GPL-2.0")
("GPL3" "GPL-3.0")
("NIST" "NIST-PD")
(_ license)))
'unknown-license!)))
licenses))
(define (fetch-go.mod goproxy module-path version)
"Fetch go.mod from the given GOPROXY server for the given MODULE-PATH
and VERSION and return an input port."
(let ((url (format #f "~a/~a/@v/~a.mod" goproxy
(go-path-escape module-path)
(go-path-escape version))))
(http-fetch* url)))
(define %go.mod-require-directive-rx
;; A line in a require directive is composed of a module path and
;; a version separated by whitespace and an optionnal '//' comment at
;; the end.
(make-regexp
(string-append
"^[[: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:]]+)" ;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."
;; 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 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
(values requirements replaced))
((string=? line "require (")
;; a require block begins, delegate parsing to IN-REQUIRE
(in-require requirements replaced))
((string=? line "replace (")
;; a replace block begins, delegate parsing to IN-REPLACE
(in-replace requirements replaced))
((string-prefix? "require " line)
;; 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 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 requirements replaced)))))
(define (in-require requirements replaced)
(let ((line (read-line)))
(cond
((eof-object? line)
;; this should never happen here but we ignore silently
(values requirements replaced))
((string=? line ")")
;; end of block, coming back to toplevel
(toplevel requirements replaced))
(#t
(call-with-values (lambda ()
(require-directive requirements replaced line))
in-require)))))
(define (in-replace requirements replaced)
(let ((line (read-line)))
(cond
((eof-object? line)
;; this should never happen here but we ignore silently
(values requirements replaced))
((string=? line ")")
;; end of block, coming back to toplevel
(toplevel requirements replaced))
(#t
(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))
;; 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)))
(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)
(define-record-type <vcs>
(%make-vcs url-prefix root-regex type)
vcs?
(url-prefix vcs-url-prefix)
(root-regex vcs-root-regex)
(type vcs-type))
(define (make-vcs prefix regexp type)
(%make-vcs prefix (make-regexp regexp) type))
(define known-vcs
;; See the following URL for the official Go equivalent:
;; https://github.com/golang/go/blob/846dce9d05f19a1f53465e62a304dea21b99f910/src/cmd/go/internal/vcs/vcs.go#L1026-L1087
(list
(make-vcs
"github.com"
"^(github\\.com/[A-Za-z0-9_.\\-]+/[A-Za-z0-9_.\\-]+)(/[A-Za-z0-9_.\\-]+)*$"
'git)
(make-vcs
"bitbucket.org"
"^(bitbucket\\.org/([A-Za-z0-9_.\\-]+/[A-Za-z0-9_.\\-]+))(/[A-Za-z0-9_.\\-]+)*$"
'unknown)
(make-vcs
"hub.jazz.net/git/"
"^(hub\\.jazz\\.net/git/[a-z0-9]+/[A-Za-z0-9_.\\-]+)(/[A-Za-z0-9_.\\-]+)*$"
'git)
(make-vcs
"git.apache.org"
"^(git\\.apache\\.org/[a-z0-9_.\\-]+\\.git)(/[A-Za-z0-9_.\\-]+)*$"
'git)
(make-vcs
"git.openstack.org"
"^(git\\.openstack\\.org/[A-Za-z0-9_.\\-]+/[A-Za-z0-9_.\\-]+)(\\.git)?\
(/[A-Za-z0-9_.\\-]+)*$"
'git)))
(define (module-path->repository-root module-path)
"Infer the repository root from a module path. Go modules can be
defined at any level of a repository tree, but querying for the meta tag
usually can only be done from the web page at the root of the repository,
hence the need to derive this information."
;; For reference, see: https://golang.org/ref/mod#vcs-find.
(define vcs-qualifiers '(".bzr" ".fossil" ".git" ".hg" ".svn"))
(define (vcs-qualified-module-path->root-repo-url module-path)
(let* ((vcs-qualifiers-group (string-join vcs-qualifiers "|"))
(pattern (format #f "^(.*(~a))(/|$)" vcs-qualifiers-group))
(m (string-match pattern module-path)))
(and=> m (cut match:substring <> 1))))
(or (and=> (find (lambda (vcs)
(string-prefix? (vcs-url-prefix vcs) module-path))
known-vcs)
(lambda (vcs)
(match:substring (regexp-exec (vcs-root-regex vcs)
module-path) 1)))
(vcs-qualified-module-path->root-repo-url module-path)
module-path))
(define* (go-module->guix-package-name module-path #:optional version)
"Converts a module's path to the canonical Guix format for Go packages.
Optionally include a VERSION string to append to the name."
;; Map dot, slash and underscore characters to hyphens.
(let ((module-path* (string-map (lambda (c)
(if (member c '(#\. #\/ #\_))
#\-
c))
module-path)))
(string-downcase (string-append "go-" module-path*
(if version
(string-append "-" version)
"")))))
(define (strip-.git-suffix/maybe repo-url)
"Strip a repository URL '.git' suffix from REPO-URL if hosted at GitHub."
(match repo-url
((and (? (cut string-prefix? "https://github.com" <>))
(? (cut string-suffix? ".git" <>)))
(string-drop-right repo-url 4))
(_ repo-url)))
(define-record-type <module-meta>
(make-module-meta import-prefix vcs repo-root)
module-meta?
(import-prefix module-meta-import-prefix)
(vcs module-meta-vcs) ;a symbol
(repo-root module-meta-repo-root))
(define (fetch-module-meta-data module-path)
"Retrieve the module meta-data from its landing page. This is necessary
because goproxy servers don't currently provide all the information needed to
build a package."
;; <meta name="go-import" content="import-prefix vcs repo-root">
(let* ((meta-data (http-fetch* (format #f "https://~a?go-get=1" module-path)))
(select (sxpath `(// head (meta (@ (equal? (name "go-import"))))
// content))))
(match (select (html->sxml meta-data #:strict? #t))
(() #f) ;nothing selected
(((content content-text))
(match (string-split content-text #\space)
((root-path vcs repo-url)
(make-module-meta root-path (string->symbol vcs)
(strip-.git-suffix/maybe repo-url))))))))
(define (module-meta-data-repo-url meta-data goproxy)
"Return the URL where the fetcher which will be used can download the
source."
(if (member (module-meta-vcs meta-data) '(fossil mod))
goproxy
(module-meta-repo-root meta-data)))
;; XXX: Copied from (guix scripts hash).
(define (vcs-file? file stat)
(case (stat:type stat)
((directory)
(member (basename file) '(".bzr" ".git" ".hg" ".svn" "CVS")))
((regular)
;; Git sub-modules have a '.git' file that is a regular text file.
(string=? (basename file) ".git"))
(else
#f)))
;; XXX: Adapted from 'file-hash' in (guix scripts hash).
(define* (file-hash file #:optional (algorithm (hash-algorithm sha256)))
;; Compute the hash of FILE.
(let-values (((port get-hash) (open-hash-port algorithm)))
(write-file file port #:select? (negate vcs-file?))
(force-output port)
(get-hash)))
(define* (git-checkout-hash url reference algorithm)
"Return the ALGORITHM hash of the checkout of URL at REFERENCE, a commit or
tag."
(define cache
(string-append (or (getenv "TMPDIR") "/tmp")
"/guix-import-go-"
(passwd:name (getpwuid (getuid)))))
;; Use a custom cache to avoid cluttering the default one under
;; ~/.cache/guix, but choose one under /tmp so that it's persistent across
;; subsequent "guix import" invocations.
(mkdir-p cache)
(chmod cache #o700)
(let-values (((checkout commit _)
(parameterize ((%repository-cache-directory cache))
(update-cached-checkout url
#:ref
`(tag-or-commit . ,reference)))))
(file-hash checkout algorithm)))
(define (vcs->origin vcs-type vcs-repo-url version)
"Generate the `origin' block of a package depending on what type of source
control system is being used."
(case vcs-type
((git)
(let ((plain-version? (string=? version (go-version->git-ref version)))
(v-prefixed? (string-prefix? "v" version)))
`(origin
(method git-fetch)
(uri (git-reference
(url ,vcs-repo-url)
;; This is done because the version field of the package,
;; which the generated quoted expression refers to, has been
;; stripped of any 'v' prefixed.
(commit ,(if (and plain-version? v-prefixed?)
'(string-append "v" version)
'(go-version->git-ref version)))))
(file-name (git-file-name name version))
(sha256
(base32
,(bytevector->nix-base32-string
(git-checkout-hash vcs-repo-url (go-version->git-ref version)
(hash-algorithm sha256))))))))
((hg)
`(origin
(method hg-fetch)
(uri (hg-reference
(url ,vcs-repo-url)
(changeset ,version)))
(file-name (string-append name "-" version "-checkout"))
(sha256
(base32
;; FIXME: populate hash for hg repo checkout
"0000000000000000000000000000000000000000000000000000"))))
((svn)
`(origin
(method svn-fetch)
(uri (svn-reference
(url ,vcs-repo-url)
(revision (string->number version))))
(file-name (string-append name "-" version "-checkout"))
(sha256
(base32
;; FIXME: populate hash for svn repo checkout
"0000000000000000000000000000000000000000000000000000"))))
(else
(raise
(formatted-message (G_ "unsupported vcs type '~a' for package '~a'")
vcs-type vcs-repo-url)))))
(define* (go-module->guix-package module-path #:key
(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
;; Elide the "v" prefix Go uses.
(strip-v-prefix (cut string-trim <> #\v))
;; 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 (if pin-versions?
dependencies+versions
(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))
(synopsis (go-package-synopsis root-module-path))
(description (go-package-description module-path))
(licenses (go-package-licenses module-path)))
(values
`(package
(name ,guix-name)
(version ,(strip-v-prefix version*))
(source
,(vcs->origin vcs-type vcs-repo-url version*))
(build-system go-build-system)
(arguments
'(#:import-path ,root-module-path))
,@(maybe-propagated-inputs
(map (match-lambda
((name version)
(go-module->guix-package-name name (strip-v-prefix version)))
(name
(go-module->guix-package-name name)))
dependencies))
(home-page ,(format #f "https://~a" root-module-path))
(synopsis ,synopsis)
(description ,(and=> description beautify-description))
(license ,(match (list->licenses licenses)
(() #f) ;unknown license
((license) ;a single license
license)
((license ...) ;a list of licenses
`(list ,@license)))))
(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 "https://proxy.golang.org")
version
pin-versions?)
(recursive-import
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))