diff options
Diffstat (limited to 'guix/import/go.scm')
| -rw-r--r-- | guix/import/go.scm | 465 |
1 files changed, 291 insertions, 174 deletions
diff --git a/guix/import/go.scm b/guix/import/go.scm index 7452b4c903..bc53f8f558 100644 --- a/guix/import/go.scm +++ b/guix/import/go.scm @@ -4,6 +4,7 @@ ;;; 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. ;;; @@ -32,7 +33,7 @@ #:use-module (guix http-client) #:use-module ((guix licenses) #:prefix license:) #:use-module (guix memoization) - #:autoload (htmlprag) (html->sxml) ;from Guile-Lib + #:use-module (htmlprag) ;from Guile-Lib #:autoload (guix git) (update-cached-checkout) #:autoload (gcrypt hash) (open-hash-port hash-algorithm sha256) #:autoload (guix serialization) (write-file) @@ -42,20 +43,29 @@ #: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 (sxml xpath) + #: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-path-escape - go-module->guix-package + #:export (go-module->guix-package go-module-recursive-import)) +;;; Parameterize htmlprag to parse valid HTML more reliably. +(%strict-tokenizer? #t) + ;;; Commentary: ;;; ;;; (guix import go) attempts to make it easier to create Guix package @@ -83,12 +93,18 @@ ;;; 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: +(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 @@ -98,54 +114,87 @@ https://godoc.org/golang.org/x/mod/module#hdr-Escaped_Paths)." (string-append "!" (string-downcase (match:substring occurrence)))) (regexp-substitute/global #f "[A-Z]" path 'pre escape 'post)) -(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")) +;; 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\"). The data is scraped from -the https://pkg.go.dev/ web site." - (let*-values (((url) (string-append "https://pkg.go.dev/" name - "?tab=licenses")) - ((response body) (http-get url)) - ;; 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*)))) - (and (eq? (response-code response) 200) - (match (select (html->sxml body)) - (() #f) ;nothing selected - (licenses licenses))))) - -(define (go.pkg.dev-info name) - (http-get (string-append "https://pkg.go.dev/" name))) -(define go.pkg.dev-info* - (memoize go.pkg.dev-info)) +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)))) + +(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\". The data is scraped from the -https://pkg.go.dev/ web site." - (let*-values (((response body) (go.pkg.dev-info* name)) - ;; Extract the text contained in a h2 child node of any - ;; element marked with a "License" class attribute. - ((select) (sxpath - `(// (section - (@ (equal? (class "Documentation-overview")))) - (p 1))))) - (and (eq? (response-code response) 200) - (match (select (html->sxml body)) - (() #f) ;nothing selected - (((p . strings)) - ;; The paragraph text is returned as a list of strings embedding - ;; newline characters. Join them and strip the newline - ;; characters. - (string-delete #\newline (string-join strings))))))) +e.g. \"google.golang.org/protobuf/proto\"." + (let* ((body (go.pkg.dev-info name)) + (sxml (html->sxml body)) + (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, @@ -153,17 +202,17 @@ 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*-values (((response body) (go.pkg.dev-info* module-name)) - ;; Extract the text contained in a h2 child node of any - ;; element marked with a "License" class attribute. - ((select) (sxpath - `(// (div (@ (equal? (class "UnitReadme-content")))) - // h3 *text*)))) - (and (eq? (response-code response) 200) - (match (select (html->sxml body)) - (() #f) ;nothing selected - ((title more ...) ;title is the first string of the list - (string-trim-both title)))))) + (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)) + (() #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 @@ -188,13 +237,13 @@ corresponding Guix license or 'unknown-license!" 'unknown-license!))) licenses)) -(define (fetch-go.mod goproxy-url module-path version) - "Fetches go.mod from the given GOPROXY-URL server for the given MODULE-PATH -and VERSION." - (let ((url (format #f "~a/~a/@v/~a.mod" goproxy-url +(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))) + (http-fetch* url))) (define %go.mod-require-directive-rx ;; A line in a require directive is composed of a module path and @@ -202,118 +251,119 @@ and VERSION." ;; 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:]]+))?"))) - -(define (parse-go.mod port) - "Parse the go.mod file accessible via the input PORT, returning a list of -requirements." - (define-record-type <results> - (make-results requirements replacements) - results? - (requirements results-requirements) - (replacements results-replacements)) + "([^[: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 results) - "Main parser, RESULTS is a pair of alist serving as accumulator for - all encountered requirements and replacements." - (let ((line (read-line port))) + (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) - (let ((line (read-line port))) + (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) - (let ((line (read-line port))) + (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 (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) @@ -324,8 +374,10 @@ requirements." (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)) + (%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 @@ -376,13 +428,27 @@ hence the need to derive this information." (vcs-qualified-module-path->root-repo-url module-path) module-path)) -(define (go-module->guix-package-name module-path) - "Converts a module's path to the canonical Guix format for Go packages." - (string-downcase (string-append "go-" (string-replace-substring - (string-replace-substring - 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) @@ -396,21 +462,22 @@ hence the need to derive this information." 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* ((port (http-fetch (format #f "https://~a?go-get=1" module-path))) + (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 (call-with-port port html->sxml)) - (() #f) ;nothing selected + (match (select (html->sxml meta-data)) + (() #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) 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-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-url + goproxy (module-meta-repo-root meta-data))) ;; XXX: Copied from (guix scripts hash). @@ -463,6 +530,9 @@ control system is being used." (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))))) @@ -500,48 +570,95 @@ 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)) - (port (fetch-go.mod goproxy-url module-path latest-version)) - (dependencies (map car (call-with-port port parse-go.mod))) + (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-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))) (values `(package (name ,guix-name) - ;; Elide the "v" prefix Go uses - (version ,(string-trim latest-version #\v)) + (version ,(strip-v-prefix version*)) (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-inputs (map go-module->guix-package-name dependencies)) + ,@(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 ,description) - (license ,(match (and=> licenses list->licenses) - ((license) license) - ((licenses ...) `(list ,@licenses)) - (x x)))) - dependencies))) + (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-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)) |