opam.scm 17 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393
  1. ;;; GNU Guix --- Functional package management for GNU
  2. ;;; Copyright © 2018 Julien Lepiller <julien@lepiller.eu>
  3. ;;; Copyright © 2020 Martin Becze <mjbecze@riseup.net>
  4. ;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz>
  5. ;;;
  6. ;;; This file is part of GNU Guix.
  7. ;;;
  8. ;;; GNU Guix is free software; you can redistribute it and/or modify it
  9. ;;; under the terms of the GNU General Public License as published by
  10. ;;; the Free Software Foundation; either version 3 of the License, or (at
  11. ;;; your option) any later version.
  12. ;;;
  13. ;;; GNU Guix is distributed in the hope that it will be useful, but
  14. ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  15. ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
  16. ;;; GNU General Public License for more details.
  17. ;;;
  18. ;;; You should have received a copy of the GNU General Public License
  19. ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
  20. (define-module (guix import opam)
  21. #:use-module (ice-9 ftw)
  22. #:use-module (ice-9 match)
  23. #:use-module (ice-9 peg)
  24. #:use-module (ice-9 receive)
  25. #:use-module ((ice-9 rdelim) #:select (read-line))
  26. #:use-module (ice-9 textual-ports)
  27. #:use-module (ice-9 vlist)
  28. #:use-module (srfi srfi-1)
  29. #:use-module (srfi srfi-2)
  30. #:use-module (web uri)
  31. #:use-module (guix build-system)
  32. #:use-module (guix build-system ocaml)
  33. #:use-module (guix http-client)
  34. #:use-module (guix git)
  35. #:use-module (guix ui)
  36. #:use-module (guix packages)
  37. #:use-module (guix upstream)
  38. #:use-module (guix utils)
  39. #:use-module (guix import utils)
  40. #:use-module ((guix licenses) #:prefix license:)
  41. #:export (opam->guix-package
  42. opam-recursive-import
  43. %opam-updater
  44. ;; The following patterns are exported for testing purposes.
  45. string-pat
  46. multiline-string
  47. list-pat
  48. dict
  49. condition))
  50. ;; Define a PEG parser for the opam format
  51. (define-peg-pattern comment none (and "#" (* COMMCHR) "\n"))
  52. (define-peg-pattern SP none (or " " "\n" comment))
  53. (define-peg-pattern SP2 body (or " " "\n"))
  54. (define-peg-pattern QUOTE none "\"")
  55. (define-peg-pattern QUOTE2 body "\"")
  56. (define-peg-pattern COLON none ":")
  57. ;; A string character is any character that is not a quote, or a quote preceded by a backslash.
  58. (define-peg-pattern COMMCHR none
  59. (or " " "!" "\\" "\"" (range #\# #\頋)))
  60. (define-peg-pattern STRCHR body
  61. (or " " "!" "\n" (and (ignore "\\") "\"")
  62. (ignore "\\\n") (and (ignore "\\") "\\")
  63. (range #\# #\頋)))
  64. (define-peg-pattern operator all (or "=" "!" "<" ">"))
  65. (define-peg-pattern records body (and (* SP) (* (and (or record weird-record) (* SP)))))
  66. (define-peg-pattern record all (and key COLON (* SP) value))
  67. (define-peg-pattern weird-record all (and key (* SP) dict))
  68. (define-peg-pattern key body (+ (or (range #\a #\z) "-")))
  69. (define-peg-pattern value body (and (or conditional-value ground-value operator) (* SP)))
  70. (define-peg-pattern choice-pat all (and (ignore "(") (* SP) choice (* SP) (ignore ")")))
  71. (define-peg-pattern choice body
  72. (or (and (or conditional-value ground-value) (* SP) (ignore "|") (* SP) choice)
  73. group-pat
  74. conditional-value
  75. ground-value))
  76. (define-peg-pattern group-pat all
  77. (and (or conditional-value ground-value) (* SP) (ignore "&") (* SP)
  78. (or group-pat conditional-value ground-value)))
  79. (define-peg-pattern ground-value body (and (or multiline-string string-pat choice-pat list-pat var) (* SP)))
  80. (define-peg-pattern conditional-value all (and ground-value (* SP) condition))
  81. (define-peg-pattern string-pat all (and QUOTE (* STRCHR) QUOTE))
  82. (define-peg-pattern list-pat all (and (ignore "[") (* SP) (* (and value (* SP))) (ignore "]")))
  83. (define-peg-pattern var all (+ (or (range #\a #\z) "-")))
  84. (define-peg-pattern multiline-string all
  85. (and QUOTE QUOTE QUOTE (* SP)
  86. (* (or SP2 STRCHR (and QUOTE2 (not-followed-by QUOTE))
  87. (and QUOTE2 QUOTE2 (not-followed-by QUOTE))))
  88. QUOTE QUOTE QUOTE))
  89. (define-peg-pattern dict all (and (ignore "{") (* SP) records (* SP) (ignore "}")))
  90. (define-peg-pattern condition body (and (ignore "{") condition-form (ignore "}")))
  91. (define-peg-pattern condition-form body
  92. (and
  93. (* SP)
  94. (or condition-and condition-or condition-form2)
  95. (* SP)))
  96. (define-peg-pattern condition-form2 body
  97. (and (* SP) (or condition-greater-or-equal condition-greater
  98. condition-lower-or-equal condition-lower
  99. condition-neq condition-eq condition-not
  100. condition-content) (* SP)))
  101. ;(define-peg-pattern condition-operator all (and (ignore operator) (* SP) condition-string))
  102. (define-peg-pattern condition-greater-or-equal all (and (ignore (and ">" "=")) (* SP) condition-string))
  103. (define-peg-pattern condition-greater all (and (ignore ">") (* SP) condition-string))
  104. (define-peg-pattern condition-lower-or-equal all (and (ignore (and "<" "=")) (* SP) condition-string))
  105. (define-peg-pattern condition-lower all (and (ignore "<") (* SP) condition-string))
  106. (define-peg-pattern condition-and all (and condition-form2 (* SP) (? (ignore "&")) (* SP) condition-form))
  107. (define-peg-pattern condition-or all (and condition-form2 (* SP) (ignore "|") (* SP) condition-form))
  108. (define-peg-pattern condition-eq all (and (? condition-content) (* SP) (ignore "=") (* SP) condition-content))
  109. (define-peg-pattern condition-neq all (and (? condition-content) (* SP) (ignore (and "!" "=")) (* SP) condition-content))
  110. (define-peg-pattern condition-not all (and (ignore (and "!")) (* SP) condition-content))
  111. (define-peg-pattern condition-content body (or condition-paren condition-string condition-var))
  112. (define-peg-pattern condition-content2 body (and condition-content (* SP) (not-followed-by (or "&" "=" "!"))))
  113. (define-peg-pattern condition-paren body (and "(" condition-form ")"))
  114. (define-peg-pattern condition-string all (and QUOTE (* STRCHR) QUOTE))
  115. (define-peg-pattern condition-var all (+ (or (range #\a #\z) "-" ":")))
  116. (define* (get-opam-repository #:optional repo)
  117. "Update or fetch the latest version of the opam repository and return the
  118. path to the repository."
  119. (let ((url (cond
  120. ((or (not repo) (equal? repo 'opam))
  121. "https://github.com/ocaml/opam-repository")
  122. ((string-prefix? "coq-" (symbol->string repo))
  123. "https://github.com/coq/opam-coq-archive")
  124. ((equal? repo 'coq) "https://github.com/coq/opam-coq-archive")
  125. (else (throw 'unknown-repository repo)))))
  126. (receive (location commit _)
  127. (update-cached-checkout url)
  128. (cond
  129. ((or (not repo) (equal? repo 'opam))
  130. location)
  131. ((equal? repo 'coq)
  132. (string-append location "/released"))
  133. ((string-prefix? "coq-" (symbol->string repo))
  134. (string-append location "/" (substring (symbol->string repo) 4)))
  135. (else location)))))
  136. ;; Prevent Guile 3 from inlining this procedure so we can mock it in tests.
  137. (set! get-opam-repository get-opam-repository)
  138. (define (latest-version versions)
  139. "Find the most recent version from a list of versions."
  140. (fold (lambda (a b) (if (version>? a b) a b)) (car versions) versions))
  141. (define (find-latest-version package repository)
  142. "Get the latest version of a package as described in the given repository."
  143. (let* ((dir (string-append repository "/packages/" package))
  144. (versions (scandir dir (lambda (name) (not (string-prefix? "." name))))))
  145. (if versions
  146. (let ((versions (map
  147. (lambda (dir)
  148. (string-join (cdr (string-split dir #\.)) "."))
  149. versions)))
  150. ;; Workaround for janestreet re-versionning
  151. (let ((v-versions (filter (lambda (version) (string-prefix? "v" version)) versions)))
  152. (if (null? v-versions)
  153. (latest-version versions)
  154. (string-append "v" (latest-version (map (lambda (version) (substring version 1)) v-versions))))))
  155. (begin
  156. (format #t (G_ "Package not found in opam repository: ~a~%") package)
  157. #f))))
  158. (define (get-metadata opam-file)
  159. (with-input-from-file opam-file
  160. (lambda _
  161. (peg:tree (match-pattern records (get-string-all (current-input-port)))))))
  162. (define (substitute-char str what with)
  163. (string-join (string-split str what) with))
  164. (define (ocaml-name->guix-name name)
  165. (substitute-char
  166. (cond
  167. ((equal? name "ocamlfind") "ocaml-findlib")
  168. ((equal? name "coq") name)
  169. ((string-prefix? "ocaml" name) name)
  170. ((string-prefix? "conf-" name) (substring name 5))
  171. (else (string-append "ocaml-" name)))
  172. #\_ "-"))
  173. (define (metadata-ref file lookup)
  174. (fold (lambda (record acc)
  175. (match record
  176. ((record key val)
  177. (if (equal? key lookup)
  178. (match val
  179. (('list-pat . stuff) stuff)
  180. (('string-pat stuff) stuff)
  181. (('multiline-string stuff) stuff)
  182. (('dict records ...) records))
  183. acc))))
  184. #f file))
  185. (define (native? condition)
  186. (match condition
  187. (('condition-var var)
  188. (match var
  189. ("with-test" #t)
  190. ("test" #t)
  191. ("build" #t)
  192. (_ #f)))
  193. ((or ('condition-or cond-left cond-right) ('condition-and cond-left cond-right))
  194. (or (native? cond-left)
  195. (native? cond-right)))
  196. (_ #f)))
  197. (define (dependency->input dependency)
  198. (match dependency
  199. (('string-pat str) str)
  200. ;; Arbitrary select the first dependency
  201. (('choice-pat choice ...) (dependency->input (car choice)))
  202. (('group-pat val ...) (map dependency->input val))
  203. (('conditional-value val condition)
  204. (if (native? condition) "" (dependency->input val)))))
  205. (define (dependency->native-input dependency)
  206. (match dependency
  207. (('string-pat str) "")
  208. ;; Arbitrary select the first dependency
  209. (('choice-pat choice ...) (dependency->native-input (car choice)))
  210. (('group-pat val ...) (map dependency->native-input val))
  211. (('conditional-value val condition)
  212. (if (native? condition) (dependency->input val) ""))))
  213. (define (dependency->name dependency)
  214. (match dependency
  215. (('string-pat str) str)
  216. ;; Arbitrary select the first dependency
  217. (('choice-pat choice ...) (dependency->name (car choice)))
  218. (('group-pat val ...) (map dependency->name val))
  219. (('conditional-value val condition)
  220. (dependency->name val))))
  221. (define (dependency-list->names lst)
  222. (filter
  223. (lambda (name)
  224. (not (or
  225. (string-prefix? "conf-" name)
  226. (equal? name "ocaml")
  227. (equal? name "findlib"))))
  228. (map dependency->name lst)))
  229. (define (ocaml-names->guix-names names)
  230. (map ocaml-name->guix-name
  231. (remove (lambda (name)
  232. (or (equal? "" name))
  233. (equal? "ocaml" name))
  234. names)))
  235. (define (filter-dependencies depends)
  236. "Remove implicit dependencies from the list of dependencies in @var{depends}."
  237. (filter (lambda (name)
  238. (and (not (member name '("" "ocaml" "ocamlfind" "dune" "jbuilder")))
  239. (not (string-prefix? "base-" name))))
  240. depends))
  241. (define (depends->inputs depends)
  242. (filter-dependencies (map dependency->input depends)))
  243. (define (depends->native-inputs depends)
  244. (filter (lambda (name) (not (equal? "" name)))
  245. (map dependency->native-input depends)))
  246. (define (dependency-list->inputs lst)
  247. (map
  248. (lambda (dependency)
  249. (list dependency (list 'unquote (string->symbol dependency))))
  250. (ocaml-names->guix-names lst)))
  251. (define* (opam-fetch name #:optional (repository (get-opam-repository)))
  252. (and-let* ((repository repository)
  253. (version (find-latest-version name repository))
  254. (file (string-append repository "/packages/" name "/" name "." version "/opam")))
  255. `(("metadata" ,@(get-metadata file))
  256. ("version" . ,(if (string-prefix? "v" version)
  257. (substring version 1)
  258. version)))))
  259. (define* (opam->guix-package name #:key (repo 'opam) version)
  260. "Import OPAM package NAME from REPOSITORY (a directory name) or, if
  261. REPOSITORY is #f, from the official OPAM repository. Return a 'package' sexp
  262. or #f on failure."
  263. (and-let* ((opam-file (opam-fetch name (get-opam-repository repo)))
  264. (version (assoc-ref opam-file "version"))
  265. (opam-content (assoc-ref opam-file "metadata"))
  266. (url-dict (metadata-ref opam-content "url"))
  267. (source-url (or (metadata-ref url-dict "src")
  268. (metadata-ref url-dict "archive")))
  269. (requirements (metadata-ref opam-content "depends"))
  270. (names (dependency-list->names requirements))
  271. (dependencies (filter-dependencies names))
  272. (native-dependencies (depends->native-inputs requirements))
  273. (inputs (dependency-list->inputs (depends->inputs requirements)))
  274. (native-inputs (dependency-list->inputs
  275. ;; Do not add dune nor jbuilder since they are
  276. ;; implicit inputs of the dune-build-system.
  277. (filter
  278. (lambda (name)
  279. (not (member name '("dune" "jbuilder"))))
  280. native-dependencies))))
  281. (let ((use-dune? (member "dune" names)))
  282. (call-with-temporary-output-file
  283. (lambda (temp port)
  284. (and (url-fetch source-url temp)
  285. (values
  286. `(package
  287. (name ,(ocaml-name->guix-name name))
  288. (version ,(if (string-prefix? "v" version)
  289. (substring version 1)
  290. version))
  291. (source
  292. (origin
  293. (method url-fetch)
  294. (uri ,source-url)
  295. (sha256 (base32 ,(guix-hash-url temp)))))
  296. (build-system ,(if use-dune?
  297. 'dune-build-system
  298. 'ocaml-build-system))
  299. ,@(if (null? inputs)
  300. '()
  301. `((propagated-inputs ,(list 'quasiquote inputs))))
  302. ,@(if (null? native-inputs)
  303. '()
  304. `((native-inputs ,(list 'quasiquote native-inputs))))
  305. ,@(if (equal? name (guix-name->opam-name (ocaml-name->guix-name name)))
  306. '()
  307. `((properties
  308. ,(list 'quasiquote `((upstream-name . ,name))))))
  309. (home-page ,(metadata-ref opam-content "homepage"))
  310. (synopsis ,(metadata-ref opam-content "synopsis"))
  311. (description ,(metadata-ref opam-content "description"))
  312. (license ,(spdx-string->license
  313. (metadata-ref opam-content "license"))))
  314. (filter
  315. (lambda (name)
  316. (not (member name '("dune" "jbuilder"))))
  317. dependencies))))))))
  318. (define* (opam-recursive-import package-name #:key repo)
  319. (recursive-import package-name
  320. #:repo->guix-package opam->guix-package
  321. #:guix-name ocaml-name->guix-name
  322. #:repo repo))
  323. (define (guix-name->opam-name name)
  324. (if (string-prefix? "ocaml-" name)
  325. (substring name 6)
  326. name))
  327. (define (guix-package->opam-name package)
  328. "Given an OCaml PACKAGE built from OPAM, return the name of the
  329. package in OPAM."
  330. (let ((upstream-name (assoc-ref
  331. (package-properties package)
  332. 'upstream-name))
  333. (name (package-name package)))
  334. (if upstream-name
  335. upstream-name
  336. (guix-name->opam-name name))))
  337. (define (opam-package? package)
  338. "Return true if PACKAGE is an OCaml package from OPAM"
  339. (and
  340. (member (build-system-name (package-build-system package)) '(dune ocaml))
  341. (not (string-prefix? "ocaml4" (package-name package)))))
  342. (define (latest-release package)
  343. "Return an <upstream-source> for the latest release of PACKAGE."
  344. (and-let* ((opam-name (guix-package->opam-name package))
  345. (opam-file (opam-fetch opam-name))
  346. (version (assoc-ref opam-file "version"))
  347. (opam-content (assoc-ref opam-file "metadata"))
  348. (url-dict (metadata-ref opam-content "url"))
  349. (source-url (metadata-ref url-dict "src")))
  350. (upstream-source
  351. (package (package-name package))
  352. (version version)
  353. (urls (list source-url)))))
  354. (define %opam-updater
  355. (upstream-updater
  356. (name 'opam)
  357. (description "Updater for OPAM packages")
  358. (pred opam-package?)
  359. (latest latest-release)))