Commit | Line | Data |
---|---|---|
02e2e093 KCB |
1 | ;;; GNU Guix --- Functional package management for GNU |
2 | ;;; Copyright © 2020 Katherine Cox-Buday <cox.katherine.e@gmail.com> | |
3 | ;;; Copyright © 2020 Helio Machado <0x2b3bfa0+guix@googlemail.com> | |
4 | ;;; Copyright © 2021 François Joulaud <francois.joulaud@radiofrance.com> | |
5 | ;;; Copyright © 2021 Maxim Cournoyer <maxim.cournoyer@gmail.com> | |
d028aef3 | 6 | ;;; Copyright © 2021 Ludovic Courtès <ludo@gnu.org> |
426ade6c | 7 | ;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz> |
793ba333 | 8 | ;;; Copyright © 2021 Sarah Morgensen <iskarian@mgsn.dev> |
02e2e093 KCB |
9 | ;;; |
10 | ;;; This file is part of GNU Guix. | |
11 | ;;; | |
12 | ;;; GNU Guix is free software; you can redistribute it and/or modify it | |
13 | ;;; under the terms of the GNU General Public License as published by | |
14 | ;;; the Free Software Foundation; either version 3 of the License, or (at | |
15 | ;;; your option) any later version. | |
16 | ;;; | |
17 | ;;; GNU Guix is distributed in the hope that it will be useful, but | |
18 | ;;; WITHOUT ANY WARRANTY; without even the implied warranty of | |
19 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
20 | ;;; GNU General Public License for more details. | |
21 | ;;; | |
22 | ;;; You should have received a copy of the GNU General Public License | |
23 | ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. | |
24 | ||
25 | (define-module (guix import go) | |
26 | #:use-module (guix build-system go) | |
27 | #:use-module (guix git) | |
28 | #:use-module (guix i18n) | |
29 | #:use-module (guix diagnostics) | |
30 | #:use-module (guix import utils) | |
31 | #:use-module (guix import json) | |
32 | #:use-module (guix packages) | |
33 | #:use-module ((guix utils) #:select (string-replace-substring)) | |
34 | #:use-module (guix http-client) | |
35 | #:use-module ((guix licenses) #:prefix license:) | |
36 | #:use-module (guix memoization) | |
34db952a | 37 | #:autoload (htmlprag) (html->sxml) ;from Guile-Lib |
d028aef3 LC |
38 | #:autoload (guix git) (update-cached-checkout) |
39 | #:autoload (gcrypt hash) (open-hash-port hash-algorithm sha256) | |
40 | #:autoload (guix serialization) (write-file) | |
41 | #:autoload (guix base32) (bytevector->nix-base32-string) | |
42 | #:autoload (guix build utils) (mkdir-p) | |
02e2e093 | 43 | #:use-module (ice-9 match) |
793ba333 | 44 | #:use-module (ice-9 peg) |
02e2e093 KCB |
45 | #:use-module (ice-9 rdelim) |
46 | #:use-module (ice-9 receive) | |
47 | #:use-module (ice-9 regex) | |
6aee902e | 48 | #:use-module (ice-9 textual-ports) |
02e2e093 KCB |
49 | #:use-module ((rnrs io ports) #:select (call-with-port)) |
50 | #:use-module (srfi srfi-1) | |
6aee902e | 51 | #:use-module (srfi srfi-2) |
02e2e093 KCB |
52 | #:use-module (srfi srfi-9) |
53 | #:use-module (srfi srfi-11) | |
54 | #:use-module (srfi srfi-26) | |
a8b927a5 | 55 | #:use-module (srfi srfi-34) |
6aee902e MC |
56 | #:use-module (sxml match) |
57 | #:use-module ((sxml xpath) #:renamer (lambda (s) | |
58 | (if (eq? 'filter s) | |
59 | 'xfilter | |
60 | s))) | |
02e2e093 KCB |
61 | #:use-module (web client) |
62 | #:use-module (web response) | |
63 | #:use-module (web uri) | |
64 | ||
6aee902e | 65 | #:export (go-module->guix-package |
02e2e093 KCB |
66 | go-module-recursive-import)) |
67 | ||
68 | ;;; Commentary: | |
69 | ;;; | |
70 | ;;; (guix import go) attempts to make it easier to create Guix package | |
71 | ;;; declarations for Go modules. | |
72 | ;;; | |
73 | ;;; Modules in Go are a "collection of related Go packages" which are "the | |
74 | ;;; unit of source code interchange and versioning". Modules are generally | |
75 | ;;; hosted in a repository. | |
76 | ;;; | |
77 | ;;; At this point it should handle correctly modules which have only Go | |
78 | ;;; dependencies and are accessible from proxy.golang.org (or configured via | |
79 | ;;; GOPROXY). | |
80 | ;;; | |
81 | ;;; We want it to work more or less this way: | |
82 | ;;; - get latest version for the module from GOPROXY | |
83 | ;;; - infer VCS root repo from which we will check-out source by | |
84 | ;;; + recognising known patterns (like github.com) | |
85 | ;;; + or recognizing .vcs suffix | |
86 | ;;; + or parsing meta tag in HTML served at the URL | |
87 | ;;; + or (TODO) if nothing else works by using zip file served by GOPROXY | |
88 | ;;; - get go.mod from GOPROXY (which is able to synthetize one if needed) | |
89 | ;;; - extract list of dependencies from this go.mod | |
90 | ;;; | |
91 | ;;; The Go module paths are translated to a Guix package name under the | |
92 | ;;; assumption that there will be no collision. | |
93 | ||
94 | ;;; TODO list | |
a8b927a5 | 95 | ;;; - get correct hash in vcs->origin for Mercurial and Subversion |
02e2e093 KCB |
96 | |
97 | ;;; Code: | |
98 | ||
6aee902e MC |
99 | (define http-fetch* |
100 | ;; Like http-fetch, but memoized and returning the body as a string. | |
101 | (memoize (lambda args | |
102 | (call-with-port (apply http-fetch args) get-string-all)))) | |
103 | ||
104 | (define json-fetch* | |
105 | (memoize json-fetch)) | |
106 | ||
02e2e093 KCB |
107 | (define (go-path-escape path) |
108 | "Escape a module path by replacing every uppercase letter with an | |
109 | exclamation mark followed with its lowercase equivalent, as per the module | |
110 | Escaped Paths specification (see: | |
111 | https://godoc.org/golang.org/x/mod/module#hdr-Escaped_Paths)." | |
112 | (define (escape occurrence) | |
113 | (string-append "!" (string-downcase (match:substring occurrence)))) | |
114 | (regexp-substitute/global #f "[A-Z]" path 'pre escape 'post)) | |
115 | ||
6aee902e MC |
116 | ;; Prevent inlining of this procedure, which is accessed by unit tests. |
117 | (set! go-path-escape go-path-escape) | |
118 | ||
119 | (define (go.pkg.dev-info name) | |
120 | (http-fetch* (string-append "https://pkg.go.dev/" name))) | |
121 | ||
a8b927a5 MC |
122 | (define* (go-module-version-string goproxy name #:key version) |
123 | "Fetch the version string of the latest version for NAME from the given | |
124 | GOPROXY server, or for VERSION when specified." | |
125 | (let ((file (if version | |
126 | (string-append "@v/" version ".info") | |
127 | "@latest"))) | |
128 | (assoc-ref (json-fetch* (format #f "~a/~a/~a" | |
129 | goproxy (go-path-escape name) file)) | |
130 | "Version"))) | |
131 | ||
132 | (define* (go-module-available-versions goproxy name) | |
133 | "Retrieve the available versions for a given module from the module proxy. | |
134 | Versions are being returned **unordered** and may contain different versioning | |
135 | styles for the same package." | |
136 | (let* ((url (string-append goproxy "/" (go-path-escape name) "/@v/list")) | |
137 | (body (http-fetch* url)) | |
138 | (versions (remove string-null? (string-split body #\newline)))) | |
139 | (if (null? versions) | |
140 | (list (go-module-version-string goproxy name)) ;latest version | |
141 | versions))) | |
02e2e093 | 142 | |
02e2e093 KCB |
143 | (define (go-package-licenses name) |
144 | "Retrieve the list of licenses that apply to NAME, a Go package or module | |
6aee902e MC |
145 | name (e.g. \"github.com/golang/protobuf/proto\")." |
146 | (let* ((body (go.pkg.dev-info (string-append name "?tab=licenses"))) | |
147 | ;; Extract the text contained in a h2 child node of any | |
148 | ;; element marked with a "License" class attribute. | |
149 | (select (sxpath `(// (* (@ (equal? (class "License")))) | |
59d20bcf | 150 | h2 // div // *text*)))) |
55e90e55 | 151 | (select (html->sxml body #:strict? #t)))) |
6aee902e MC |
152 | |
153 | (define (sxml->texi sxml-node) | |
154 | "A very basic SXML to Texinfo converter which attempts to preserve HTML | |
155 | formatting and links as text." | |
156 | (sxml-match sxml-node | |
157 | ((strong ,text) | |
158 | (format #f "@strong{~a}" text)) | |
159 | ((a (@ (href ,url)) ,text) | |
160 | (format #f "@url{~a,~a}" url text)) | |
161 | ((code ,text) | |
162 | (format #f "@code{~a}" text)) | |
163 | (,something-else something-else))) | |
02e2e093 KCB |
164 | |
165 | (define (go-package-description name) | |
166 | "Retrieve a short description for NAME, a Go package name, | |
6aee902e MC |
167 | e.g. \"google.golang.org/protobuf/proto\"." |
168 | (let* ((body (go.pkg.dev-info name)) | |
55e90e55 | 169 | (sxml (html->sxml body #:strict? #t)) |
6aee902e MC |
170 | (overview ((sxpath |
171 | `(// | |
172 | (* (@ (equal? (class "Documentation-overview")))) | |
173 | (p 1))) sxml)) | |
174 | ;; Sometimes, the first paragraph just contains images/links that | |
175 | ;; has only "\n" for text. The following filter is designed to | |
176 | ;; omit it. | |
177 | (contains-text? (lambda (node) | |
178 | (remove string-null? | |
179 | (map string-trim-both | |
180 | (filter (node-typeof? '*text*) | |
181 | (cdr node)))))) | |
182 | (select-content (sxpath | |
183 | `(// | |
184 | (* (@ (equal? (class "UnitReadme-content")))) | |
185 | div // p ,(xfilter contains-text?)))) | |
186 | ;; Fall-back to use content; this is less desirable as it is more | |
187 | ;; verbose, but not every page has an overview. | |
188 | (description (if (not (null? overview)) | |
189 | overview | |
190 | (select-content sxml))) | |
9d915242 SMG |
191 | (description* (if (not (null? description)) |
192 | (first description) | |
193 | description))) | |
6aee902e MC |
194 | (match description* |
195 | (() #f) ;nothing selected | |
196 | ((p elements ...) | |
197 | (apply string-append (filter string? (map sxml->texi elements))))))) | |
02e2e093 KCB |
198 | |
199 | (define (go-package-synopsis module-name) | |
200 | "Retrieve a short synopsis for a Go module named MODULE-NAME, | |
201 | e.g. \"google.golang.org/protobuf\". The data is scraped from | |
202 | the https://pkg.go.dev/ web site." | |
203 | ;; Note: Only the *module* (rather than package) page has the README title | |
204 | ;; used as a synopsis on the https://pkg.go.dev web site. | |
6aee902e MC |
205 | (let* ((url (string-append "https://pkg.go.dev/" module-name)) |
206 | (body (http-fetch* url)) | |
207 | ;; Extract the text contained in a h2 child node of any | |
208 | ;; element marked with a "License" class attribute. | |
209 | (select-title (sxpath | |
210 | `(// (div (@ (equal? (class "UnitReadme-content")))) | |
211 | // h3 *text*)))) | |
55e90e55 | 212 | (match (select-title (html->sxml body #:strict? #t)) |
6aee902e MC |
213 | (() #f) ;nothing selected |
214 | ((title more ...) ;title is the first string of the list | |
215 | (string-trim-both title))))) | |
02e2e093 KCB |
216 | |
217 | (define (list->licenses licenses) | |
218 | "Given a list of LICENSES mostly following the SPDX conventions, return the | |
219 | corresponding Guix license or 'unknown-license!" | |
220 | (filter-map (lambda (license) | |
221 | (and (not (string-null? license)) | |
222 | (not (any (cut string=? <> license) | |
223 | '("AND" "OR" "WITH"))) | |
224 | ;; Adjust the license names scraped from | |
225 | ;; https://pkg.go.dev to an equivalent SPDX identifier, | |
226 | ;; if they differ (see: https://github.com/golang/pkgsite | |
227 | ;; /internal/licenses/licenses.go#L174). | |
228 | (or (spdx-string->license | |
229 | (match license | |
230 | ("BlueOak-1.0" "BlueOak-1.0.0") | |
231 | ("BSD-0-Clause" "0BSD") | |
232 | ("BSD-2-Clause" "BSD-2-Clause-FreeBSD") | |
233 | ("GPL2" "GPL-2.0") | |
234 | ("GPL3" "GPL-3.0") | |
235 | ("NIST" "NIST-PD") | |
236 | (_ license))) | |
237 | 'unknown-license!))) | |
238 | licenses)) | |
239 | ||
6aee902e MC |
240 | (define (fetch-go.mod goproxy module-path version) |
241 | "Fetch go.mod from the given GOPROXY server for the given MODULE-PATH | |
242 | and VERSION and return an input port." | |
243 | (let ((url (format #f "~a/~a/@v/~a.mod" goproxy | |
02e2e093 KCB |
244 | (go-path-escape module-path) |
245 | (go-path-escape version)))) | |
6aee902e | 246 | (http-fetch* url))) |
02e2e093 | 247 | |
02e2e093 | 248 | |
6aee902e | 249 | (define (parse-go.mod content) |
793ba333 SM |
250 | "Parse the go.mod file CONTENT, returning a list of directives, comments, |
251 | and unknown lines. Each sublist begins with a symbol (go, module, require, | |
252 | replace, exclude, retract, comment, or unknown) and is followed by one or more | |
253 | sublists. Each sublist begins with a symbol (module-path, version, file-path, | |
254 | comment, or unknown) and is followed by the indicated data." | |
255 | ;; https://golang.org/ref/mod#go-mod-file-grammar | |
256 | (define-peg-pattern NL none "\n") | |
257 | (define-peg-pattern WS none (or " " "\t" "\r")) | |
258 | (define-peg-pattern => none (and (* WS) "=>")) | |
259 | (define-peg-pattern punctuation none (or "," "=>" "[" "]" "(" ")")) | |
260 | (define-peg-pattern comment all | |
261 | (and (ignore "//") (* WS) (* (and (not-followed-by NL) peg-any)))) | |
262 | (define-peg-pattern EOL body (and (* WS) (? comment) NL)) | |
263 | (define-peg-pattern block-start none (and (* WS) "(" EOL)) | |
264 | (define-peg-pattern block-end none (and (* WS) ")" EOL)) | |
265 | (define-peg-pattern any-line body | |
266 | (and (* WS) (* (and (not-followed-by NL) peg-any)) EOL)) | |
267 | ||
268 | ;; Strings and identifiers | |
269 | (define-peg-pattern identifier body | |
270 | (+ (and (not-followed-by (or NL WS punctuation)) peg-any))) | |
271 | (define-peg-pattern string-raw body | |
272 | (and (ignore "`") (+ (and (not-followed-by "`") peg-any)) (ignore "`"))) | |
273 | (define-peg-pattern string-quoted body | |
274 | (and (ignore "\"") | |
275 | (+ (or (and (ignore "\\") peg-any) | |
276 | (and (not-followed-by "\"") peg-any))) | |
277 | (ignore "\""))) | |
278 | (define-peg-pattern string-or-ident body | |
279 | (and (* WS) (or string-raw string-quoted identifier))) | |
280 | ||
281 | (define-peg-pattern version all string-or-ident) | |
282 | (define-peg-pattern module-path all string-or-ident) | |
283 | (define-peg-pattern file-path all string-or-ident) | |
284 | ||
285 | ;; Non-directive lines | |
286 | (define-peg-pattern unknown all any-line) | |
287 | (define-peg-pattern block-line body | |
288 | (or EOL (and (not-followed-by block-end) unknown))) | |
289 | ||
290 | ;; GoDirective = "go" GoVersion newline . | |
291 | (define-peg-pattern go all (and (ignore "go") version EOL)) | |
292 | ||
293 | ;; ModuleDirective = "module" ( ModulePath | "(" newline ModulePath newline ")" ) newline . | |
294 | (define-peg-pattern module all | |
295 | (and (ignore "module") (or (and block-start module-path EOL block-end) | |
296 | (and module-path EOL)))) | |
297 | ||
298 | ;; The following directives may all be used solo or in a block | |
299 | ;; RequireSpec = ModulePath Version newline . | |
300 | (define-peg-pattern require all (and module-path version EOL)) | |
301 | (define-peg-pattern require-top body | |
302 | (and (ignore "require") | |
303 | (or (and block-start (* (or require block-line)) block-end) require))) | |
304 | ||
305 | ;; ExcludeSpec = ModulePath Version newline . | |
306 | (define-peg-pattern exclude all (and module-path version EOL)) | |
307 | (define-peg-pattern exclude-top body | |
308 | (and (ignore "exclude") | |
309 | (or (and block-start (* (or exclude block-line)) block-end) exclude))) | |
310 | ||
311 | ;; ReplaceSpec = ModulePath [ Version ] "=>" FilePath newline | |
312 | ;; | ModulePath [ Version ] "=>" ModulePath Version newline . | |
313 | (define-peg-pattern original all (or (and module-path version) module-path)) | |
314 | (define-peg-pattern with all (or (and module-path version) file-path)) | |
315 | (define-peg-pattern replace all (and original => with EOL)) | |
316 | (define-peg-pattern replace-top body | |
317 | (and (ignore "replace") | |
318 | (or (and block-start (* (or replace block-line)) block-end) replace))) | |
319 | ||
320 | ;; RetractSpec = ( Version | "[" Version "," Version "]" ) newline . | |
321 | (define-peg-pattern range all | |
322 | (and (* WS) (ignore "[") version | |
323 | (* WS) (ignore ",") version (* WS) (ignore "]"))) | |
324 | (define-peg-pattern retract all (and (or range version) EOL)) | |
325 | (define-peg-pattern retract-top body | |
326 | (and (ignore "retract") | |
327 | (or (and block-start (* (or retract block-line)) block-end) retract))) | |
328 | ||
329 | (define-peg-pattern go-mod body | |
330 | (* (and (* WS) (or go module require-top exclude-top replace-top | |
331 | retract-top EOL unknown)))) | |
332 | ||
333 | (let ((tree (peg:tree (match-pattern go-mod content))) | |
334 | (keywords '(go module require replace exclude retract comment unknown))) | |
335 | (keyword-flatten keywords tree))) | |
02e2e093 KCB |
336 | |
337 | ;; Prevent inlining of this procedure, which is accessed by unit tests. | |
338 | (set! parse-go.mod parse-go.mod) | |
339 | ||
793ba333 SM |
340 | (define (go.mod-directives go.mod directive) |
341 | "Return the list of top-level directive bodies in GO.MOD matching the symbol | |
342 | DIRECTIVE." | |
343 | (filter-map (match-lambda | |
344 | (((? (cut eq? <> directive) head) . rest) rest) | |
345 | (_ #f)) | |
346 | go.mod)) | |
347 | ||
348 | (define (go.mod-requirements go.mod) | |
349 | "Compute and return the list of requirements specified by GO.MOD." | |
350 | (define (replace directive requirements) | |
351 | (define (maybe-replace module-path new-requirement) | |
352 | ;; Do not allow version updates for indirect dependencies (see: | |
353 | ;; https://golang.org/ref/mod#go-mod-file-replace). | |
354 | (if (and (equal? module-path (first new-requirement)) | |
355 | (not (assoc-ref requirements module-path))) | |
356 | requirements | |
357 | (cons new-requirement (alist-delete module-path requirements)))) | |
358 | ||
359 | (match directive | |
360 | ((('original ('module-path module-path) . _) with . _) | |
361 | (match with | |
362 | (('with ('file-path _) . _) | |
363 | (alist-delete module-path requirements)) | |
364 | (('with ('module-path new-module-path) ('version new-version) . _) | |
365 | (maybe-replace module-path | |
366 | (list new-module-path new-version))))))) | |
367 | ||
368 | (define (require directive requirements) | |
369 | (match directive | |
370 | ((('module-path module-path) ('version version) . _) | |
371 | (cons (list module-path version) requirements)))) | |
372 | ||
373 | (let* ((requires (go.mod-directives go.mod 'require)) | |
374 | (replaces (go.mod-directives go.mod 'replace)) | |
375 | (requirements (fold require '() requires))) | |
376 | (fold replace requirements replaces))) | |
377 | ||
378 | ;; Prevent inlining of this procedure, which is accessed by unit tests. | |
379 | (set! go.mod-requirements go.mod-requirements) | |
380 | ||
02e2e093 KCB |
381 | (define-record-type <vcs> |
382 | (%make-vcs url-prefix root-regex type) | |
383 | vcs? | |
384 | (url-prefix vcs-url-prefix) | |
385 | (root-regex vcs-root-regex) | |
386 | (type vcs-type)) | |
6aee902e | 387 | |
02e2e093 | 388 | (define (make-vcs prefix regexp type) |
6aee902e MC |
389 | (%make-vcs prefix (make-regexp regexp) type)) |
390 | ||
02e2e093 KCB |
391 | (define known-vcs |
392 | ;; See the following URL for the official Go equivalent: | |
393 | ;; https://github.com/golang/go/blob/846dce9d05f19a1f53465e62a304dea21b99f910/src/cmd/go/internal/vcs/vcs.go#L1026-L1087 | |
394 | (list | |
395 | (make-vcs | |
396 | "github.com" | |
397 | "^(github\\.com/[A-Za-z0-9_.\\-]+/[A-Za-z0-9_.\\-]+)(/[A-Za-z0-9_.\\-]+)*$" | |
398 | 'git) | |
399 | (make-vcs | |
400 | "bitbucket.org" | |
401 | "^(bitbucket\\.org/([A-Za-z0-9_.\\-]+/[A-Za-z0-9_.\\-]+))(/[A-Za-z0-9_.\\-]+)*$" | |
402 | 'unknown) | |
403 | (make-vcs | |
404 | "hub.jazz.net/git/" | |
405 | "^(hub\\.jazz\\.net/git/[a-z0-9]+/[A-Za-z0-9_.\\-]+)(/[A-Za-z0-9_.\\-]+)*$" | |
406 | 'git) | |
407 | (make-vcs | |
408 | "git.apache.org" | |
409 | "^(git\\.apache\\.org/[a-z0-9_.\\-]+\\.git)(/[A-Za-z0-9_.\\-]+)*$" | |
410 | 'git) | |
411 | (make-vcs | |
412 | "git.openstack.org" | |
413 | "^(git\\.openstack\\.org/[A-Za-z0-9_.\\-]+/[A-Za-z0-9_.\\-]+)(\\.git)?\ | |
414 | (/[A-Za-z0-9_.\\-]+)*$" | |
415 | 'git))) | |
416 | ||
417 | (define (module-path->repository-root module-path) | |
418 | "Infer the repository root from a module path. Go modules can be | |
419 | defined at any level of a repository tree, but querying for the meta tag | |
420 | usually can only be done from the web page at the root of the repository, | |
421 | hence the need to derive this information." | |
422 | ||
423 | ;; For reference, see: https://golang.org/ref/mod#vcs-find. | |
424 | (define vcs-qualifiers '(".bzr" ".fossil" ".git" ".hg" ".svn")) | |
425 | ||
426 | (define (vcs-qualified-module-path->root-repo-url module-path) | |
427 | (let* ((vcs-qualifiers-group (string-join vcs-qualifiers "|")) | |
428 | (pattern (format #f "^(.*(~a))(/|$)" vcs-qualifiers-group)) | |
429 | (m (string-match pattern module-path))) | |
430 | (and=> m (cut match:substring <> 1)))) | |
431 | ||
432 | (or (and=> (find (lambda (vcs) | |
433 | (string-prefix? (vcs-url-prefix vcs) module-path)) | |
434 | known-vcs) | |
435 | (lambda (vcs) | |
436 | (match:substring (regexp-exec (vcs-root-regex vcs) | |
437 | module-path) 1))) | |
438 | (vcs-qualified-module-path->root-repo-url module-path) | |
439 | module-path)) | |
440 | ||
83f8b6d3 MC |
441 | (define* (go-module->guix-package-name module-path #:optional version) |
442 | "Converts a module's path to the canonical Guix format for Go packages. | |
443 | Optionally include a VERSION string to append to the name." | |
b1a419ea | 444 | ;; Map dot, slash, underscore and tilde characters to hyphens. |
83f8b6d3 | 445 | (let ((module-path* (string-map (lambda (c) |
b1a419ea | 446 | (if (member c '(#\. #\/ #\_ #\~)) |
83f8b6d3 MC |
447 | #\- |
448 | c)) | |
449 | module-path))) | |
450 | (string-downcase (string-append "go-" module-path* | |
451 | (if version | |
452 | (string-append "-" version) | |
453 | ""))))) | |
02e2e093 | 454 | |
6aee902e MC |
455 | (define (strip-.git-suffix/maybe repo-url) |
456 | "Strip a repository URL '.git' suffix from REPO-URL if hosted at GitHub." | |
457 | (match repo-url | |
458 | ((and (? (cut string-prefix? "https://github.com" <>)) | |
459 | (? (cut string-suffix? ".git" <>))) | |
460 | (string-drop-right repo-url 4)) | |
461 | (_ repo-url))) | |
462 | ||
02e2e093 KCB |
463 | (define-record-type <module-meta> |
464 | (make-module-meta import-prefix vcs repo-root) | |
465 | module-meta? | |
466 | (import-prefix module-meta-import-prefix) | |
467 | (vcs module-meta-vcs) ;a symbol | |
468 | (repo-root module-meta-repo-root)) | |
469 | ||
470 | (define (fetch-module-meta-data module-path) | |
471 | "Retrieve the module meta-data from its landing page. This is necessary | |
472 | because goproxy servers don't currently provide all the information needed to | |
473 | build a package." | |
5eba9c09 SMG |
474 | (define (go-import->module-meta content-text) |
475 | (match (string-split content-text #\space) | |
476 | ((root-path vcs repo-url) | |
477 | (make-module-meta root-path (string->symbol vcs) | |
478 | (strip-.git-suffix/maybe repo-url))))) | |
02e2e093 | 479 | ;; <meta name="go-import" content="import-prefix vcs repo-root"> |
6aee902e | 480 | (let* ((meta-data (http-fetch* (format #f "https://~a?go-get=1" module-path))) |
02e2e093 KCB |
481 | (select (sxpath `(// head (meta (@ (equal? (name "go-import")))) |
482 | // content)))) | |
55e90e55 | 483 | (match (select (html->sxml meta-data #:strict? #t)) |
6aee902e | 484 | (() #f) ;nothing selected |
5eba9c09 SMG |
485 | ((('content content-text) ..1) |
486 | (find (lambda (meta) | |
487 | (string-prefix? (module-meta-import-prefix meta) module-path)) | |
488 | (map go-import->module-meta content-text)))))) | |
02e2e093 | 489 | |
6aee902e | 490 | (define (module-meta-data-repo-url meta-data goproxy) |
02e2e093 KCB |
491 | "Return the URL where the fetcher which will be used can download the |
492 | source." | |
493 | (if (member (module-meta-vcs meta-data) '(fossil mod)) | |
6aee902e | 494 | goproxy |
02e2e093 KCB |
495 | (module-meta-repo-root meta-data))) |
496 | ||
d028aef3 LC |
497 | ;; XXX: Copied from (guix scripts hash). |
498 | (define (vcs-file? file stat) | |
499 | (case (stat:type stat) | |
500 | ((directory) | |
501 | (member (basename file) '(".bzr" ".git" ".hg" ".svn" "CVS"))) | |
502 | ((regular) | |
503 | ;; Git sub-modules have a '.git' file that is a regular text file. | |
504 | (string=? (basename file) ".git")) | |
505 | (else | |
506 | #f))) | |
507 | ||
508 | ;; XXX: Adapted from 'file-hash' in (guix scripts hash). | |
509 | (define* (file-hash file #:optional (algorithm (hash-algorithm sha256))) | |
510 | ;; Compute the hash of FILE. | |
511 | (let-values (((port get-hash) (open-hash-port algorithm))) | |
512 | (write-file file port #:select? (negate vcs-file?)) | |
513 | (force-output port) | |
514 | (get-hash))) | |
515 | ||
516 | (define* (git-checkout-hash url reference algorithm) | |
517 | "Return the ALGORITHM hash of the checkout of URL at REFERENCE, a commit or | |
518 | tag." | |
519 | (define cache | |
520 | (string-append (or (getenv "TMPDIR") "/tmp") | |
521 | "/guix-import-go-" | |
522 | (passwd:name (getpwuid (getuid))))) | |
523 | ||
524 | ;; Use a custom cache to avoid cluttering the default one under | |
525 | ;; ~/.cache/guix, but choose one under /tmp so that it's persistent across | |
526 | ;; subsequent "guix import" invocations. | |
527 | (mkdir-p cache) | |
528 | (chmod cache #o700) | |
529 | (let-values (((checkout commit _) | |
530 | (parameterize ((%repository-cache-directory cache)) | |
531 | (update-cached-checkout url | |
532 | #:ref | |
533 | `(tag-or-commit . ,reference))))) | |
534 | (file-hash checkout algorithm))) | |
535 | ||
02e2e093 KCB |
536 | (define (vcs->origin vcs-type vcs-repo-url version) |
537 | "Generate the `origin' block of a package depending on what type of source | |
538 | control system is being used." | |
539 | (case vcs-type | |
540 | ((git) | |
541 | (let ((plain-version? (string=? version (go-version->git-ref version))) | |
542 | (v-prefixed? (string-prefix? "v" version))) | |
543 | `(origin | |
544 | (method git-fetch) | |
545 | (uri (git-reference | |
546 | (url ,vcs-repo-url) | |
6aee902e MC |
547 | ;; This is done because the version field of the package, |
548 | ;; which the generated quoted expression refers to, has been | |
549 | ;; stripped of any 'v' prefixed. | |
02e2e093 KCB |
550 | (commit ,(if (and plain-version? v-prefixed?) |
551 | '(string-append "v" version) | |
552 | '(go-version->git-ref version))))) | |
553 | (file-name (git-file-name name version)) | |
554 | (sha256 | |
555 | (base32 | |
d028aef3 LC |
556 | ,(bytevector->nix-base32-string |
557 | (git-checkout-hash vcs-repo-url (go-version->git-ref version) | |
558 | (hash-algorithm sha256)))))))) | |
02e2e093 KCB |
559 | ((hg) |
560 | `(origin | |
561 | (method hg-fetch) | |
562 | (uri (hg-reference | |
563 | (url ,vcs-repo-url) | |
564 | (changeset ,version))) | |
565 | (file-name (string-append name "-" version "-checkout")) | |
566 | (sha256 | |
567 | (base32 | |
568 | ;; FIXME: populate hash for hg repo checkout | |
569 | "0000000000000000000000000000000000000000000000000000")))) | |
570 | ((svn) | |
571 | `(origin | |
572 | (method svn-fetch) | |
573 | (uri (svn-reference | |
574 | (url ,vcs-repo-url) | |
575 | (revision (string->number version)))) | |
576 | (file-name (string-append name "-" version "-checkout")) | |
577 | (sha256 | |
578 | (base32 | |
579 | ;; FIXME: populate hash for svn repo checkout | |
580 | "0000000000000000000000000000000000000000000000000000")))) | |
581 | (else | |
582 | (raise | |
583 | (formatted-message (G_ "unsupported vcs type '~a' for package '~a'") | |
584 | vcs-type vcs-repo-url))))) | |
585 | ||
586 | (define* (go-module->guix-package module-path #:key | |
a8b927a5 MC |
587 | (goproxy "https://proxy.golang.org") |
588 | version | |
589 | pin-versions?) | |
590 | "Return the package S-expression corresponding to MODULE-PATH at VERSION, a Go package. | |
591 | The meta-data is fetched from the GOPROXY server and https://pkg.go.dev/. | |
592 | When VERSION is unspecified, the latest version available is used." | |
593 | (let* ((available-versions (go-module-available-versions goproxy module-path)) | |
594 | (version* (or version | |
595 | (go-module-version-string goproxy module-path))) ;latest | |
83f8b6d3 MC |
596 | ;; Elide the "v" prefix Go uses. |
597 | (strip-v-prefix (cut string-trim <> #\v)) | |
a8b927a5 MC |
598 | ;; Pseudo-versions do not appear in the versions list; skip the |
599 | ;; following check. | |
600 | (_ (unless (or (go-pseudo-version? version*) | |
601 | (member version* available-versions)) | |
602 | (error (format #f "error: version ~s is not available | |
603 | hint: use one of the following available versions ~a\n" | |
604 | version* available-versions)))) | |
605 | (content (fetch-go.mod goproxy module-path version*)) | |
793ba333 | 606 | (dependencies+versions (go.mod-requirements (parse-go.mod content))) |
83f8b6d3 MC |
607 | (dependencies (if pin-versions? |
608 | dependencies+versions | |
609 | (map car dependencies+versions))) | |
02e2e093 KCB |
610 | (guix-name (go-module->guix-package-name module-path)) |
611 | (root-module-path (module-path->repository-root module-path)) | |
612 | ;; The VCS type and URL are not included in goproxy information. For | |
613 | ;; this we need to fetch it from the official module page. | |
614 | (meta-data (fetch-module-meta-data root-module-path)) | |
615 | (vcs-type (module-meta-vcs meta-data)) | |
a8b927a5 | 616 | (vcs-repo-url (module-meta-data-repo-url meta-data goproxy)) |
02e2e093 KCB |
617 | (synopsis (go-package-synopsis root-module-path)) |
618 | (description (go-package-description module-path)) | |
619 | (licenses (go-package-licenses module-path))) | |
620 | (values | |
621 | `(package | |
622 | (name ,guix-name) | |
83f8b6d3 | 623 | (version ,(strip-v-prefix version*)) |
02e2e093 | 624 | (source |
a8b927a5 | 625 | ,(vcs->origin vcs-type vcs-repo-url version*)) |
02e2e093 KCB |
626 | (build-system go-build-system) |
627 | (arguments | |
628 | '(#:import-path ,root-module-path)) | |
83f8b6d3 MC |
629 | ,@(maybe-propagated-inputs |
630 | (map (match-lambda | |
631 | ((name version) | |
632 | (go-module->guix-package-name name (strip-v-prefix version))) | |
633 | (name | |
634 | (go-module->guix-package-name name))) | |
635 | dependencies)) | |
02e2e093 KCB |
636 | (home-page ,(format #f "https://~a" root-module-path)) |
637 | (synopsis ,synopsis) | |
6aee902e MC |
638 | (description ,(and=> description beautify-description)) |
639 | (license ,(match (list->licenses licenses) | |
83f8b6d3 MC |
640 | (() #f) ;unknown license |
641 | ((license) ;a single license | |
6aee902e | 642 | license) |
83f8b6d3 | 643 | ((license ...) ;a list of licenses |
6aee902e | 644 | `(list ,@license))))) |
a8b927a5 MC |
645 | (if pin-versions? |
646 | dependencies+versions | |
647 | dependencies)))) | |
02e2e093 KCB |
648 | |
649 | (define go-module->guix-package* (memoize go-module->guix-package)) | |
650 | ||
651 | (define* (go-module-recursive-import package-name | |
a8b927a5 MC |
652 | #:key (goproxy "https://proxy.golang.org") |
653 | version | |
654 | pin-versions?) | |
655 | ||
02e2e093 KCB |
656 | (recursive-import |
657 | package-name | |
a8b927a5 MC |
658 | #:repo->guix-package |
659 | (lambda* (name #:key version repo) | |
660 | ;; Disable output buffering so that the following warning gets printed | |
661 | ;; consistently. | |
662 | (setvbuf (current-error-port) 'none) | |
663 | (guard (c ((http-get-error? c) | |
664 | (warning (G_ "Failed to import package ~s. | |
665 | reason: ~s could not be fetched: HTTP error ~a (~s). | |
666 | This package and its dependencies won't be imported.~%") | |
667 | name | |
668 | (uri->string (http-get-error-uri c)) | |
669 | (http-get-error-code c) | |
670 | (http-get-error-reason c)) | |
671 | (values '() '()))) | |
672 | (receive (package-sexp dependencies) | |
673 | (go-module->guix-package* name #:goproxy goproxy | |
674 | #:version version | |
675 | #:pin-versions? pin-versions?) | |
676 | (values package-sexp dependencies)))) | |
677 | #:guix-name go-module->guix-package-name | |
678 | #:version version)) |