go.scm 29 KB

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