go.scm 29 KB

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