123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393 |
- ;;; GNU Guix --- Functional package management for GNU
- ;;; Copyright © 2018 Julien Lepiller <julien@lepiller.eu>
- ;;; Copyright © 2020 Martin Becze <mjbecze@riseup.net>
- ;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz>
- ;;;
- ;;; This file is part of GNU Guix.
- ;;;
- ;;; GNU Guix is free software; you can redistribute it and/or modify it
- ;;; under the terms of the GNU General Public License as published by
- ;;; the Free Software Foundation; either version 3 of the License, or (at
- ;;; your option) any later version.
- ;;;
- ;;; GNU Guix is distributed in the hope that it will be useful, but
- ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
- ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- ;;; GNU General Public License for more details.
- ;;;
- ;;; You should have received a copy of the GNU General Public License
- ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
- (define-module (guix import opam)
- #:use-module (ice-9 ftw)
- #:use-module (ice-9 match)
- #:use-module (ice-9 peg)
- #:use-module (ice-9 receive)
- #:use-module ((ice-9 rdelim) #:select (read-line))
- #:use-module (ice-9 textual-ports)
- #:use-module (ice-9 vlist)
- #:use-module (srfi srfi-1)
- #:use-module (srfi srfi-2)
- #:use-module (web uri)
- #:use-module (guix build-system)
- #:use-module (guix build-system ocaml)
- #:use-module (guix http-client)
- #:use-module (guix git)
- #:use-module (guix ui)
- #:use-module (guix packages)
- #:use-module (guix upstream)
- #:use-module (guix utils)
- #:use-module (guix import utils)
- #:use-module ((guix licenses) #:prefix license:)
- #:export (opam->guix-package
- opam-recursive-import
- %opam-updater
- ;; The following patterns are exported for testing purposes.
- string-pat
- multiline-string
- list-pat
- dict
- condition))
- ;; Define a PEG parser for the opam format
- (define-peg-pattern comment none (and "#" (* COMMCHR) "\n"))
- (define-peg-pattern SP none (or " " "\n" comment))
- (define-peg-pattern SP2 body (or " " "\n"))
- (define-peg-pattern QUOTE none "\"")
- (define-peg-pattern QUOTE2 body "\"")
- (define-peg-pattern COLON none ":")
- ;; A string character is any character that is not a quote, or a quote preceded by a backslash.
- (define-peg-pattern COMMCHR none
- (or " " "!" "\\" "\"" (range #\# #\頋)))
- (define-peg-pattern STRCHR body
- (or " " "!" "\n" (and (ignore "\\") "\"")
- (ignore "\\\n") (and (ignore "\\") "\\")
- (range #\# #\頋)))
- (define-peg-pattern operator all (or "=" "!" "<" ">"))
- (define-peg-pattern records body (and (* SP) (* (and (or record weird-record) (* SP)))))
- (define-peg-pattern record all (and key COLON (* SP) value))
- (define-peg-pattern weird-record all (and key (* SP) dict))
- (define-peg-pattern key body (+ (or (range #\a #\z) "-")))
- (define-peg-pattern value body (and (or conditional-value ground-value operator) (* SP)))
- (define-peg-pattern choice-pat all (and (ignore "(") (* SP) choice (* SP) (ignore ")")))
- (define-peg-pattern choice body
- (or (and (or conditional-value ground-value) (* SP) (ignore "|") (* SP) choice)
- group-pat
- conditional-value
- ground-value))
- (define-peg-pattern group-pat all
- (and (or conditional-value ground-value) (* SP) (ignore "&") (* SP)
- (or group-pat conditional-value ground-value)))
- (define-peg-pattern ground-value body (and (or multiline-string string-pat choice-pat list-pat var) (* SP)))
- (define-peg-pattern conditional-value all (and ground-value (* SP) condition))
- (define-peg-pattern string-pat all (and QUOTE (* STRCHR) QUOTE))
- (define-peg-pattern list-pat all (and (ignore "[") (* SP) (* (and value (* SP))) (ignore "]")))
- (define-peg-pattern var all (+ (or (range #\a #\z) "-")))
- (define-peg-pattern multiline-string all
- (and QUOTE QUOTE QUOTE (* SP)
- (* (or SP2 STRCHR (and QUOTE2 (not-followed-by QUOTE))
- (and QUOTE2 QUOTE2 (not-followed-by QUOTE))))
- QUOTE QUOTE QUOTE))
- (define-peg-pattern dict all (and (ignore "{") (* SP) records (* SP) (ignore "}")))
- (define-peg-pattern condition body (and (ignore "{") condition-form (ignore "}")))
- (define-peg-pattern condition-form body
- (and
- (* SP)
- (or condition-and condition-or condition-form2)
- (* SP)))
- (define-peg-pattern condition-form2 body
- (and (* SP) (or condition-greater-or-equal condition-greater
- condition-lower-or-equal condition-lower
- condition-neq condition-eq condition-not
- condition-content) (* SP)))
- ;(define-peg-pattern condition-operator all (and (ignore operator) (* SP) condition-string))
- (define-peg-pattern condition-greater-or-equal all (and (ignore (and ">" "=")) (* SP) condition-string))
- (define-peg-pattern condition-greater all (and (ignore ">") (* SP) condition-string))
- (define-peg-pattern condition-lower-or-equal all (and (ignore (and "<" "=")) (* SP) condition-string))
- (define-peg-pattern condition-lower all (and (ignore "<") (* SP) condition-string))
- (define-peg-pattern condition-and all (and condition-form2 (* SP) (? (ignore "&")) (* SP) condition-form))
- (define-peg-pattern condition-or all (and condition-form2 (* SP) (ignore "|") (* SP) condition-form))
- (define-peg-pattern condition-eq all (and (? condition-content) (* SP) (ignore "=") (* SP) condition-content))
- (define-peg-pattern condition-neq all (and (? condition-content) (* SP) (ignore (and "!" "=")) (* SP) condition-content))
- (define-peg-pattern condition-not all (and (ignore (and "!")) (* SP) condition-content))
- (define-peg-pattern condition-content body (or condition-paren condition-string condition-var))
- (define-peg-pattern condition-content2 body (and condition-content (* SP) (not-followed-by (or "&" "=" "!"))))
- (define-peg-pattern condition-paren body (and "(" condition-form ")"))
- (define-peg-pattern condition-string all (and QUOTE (* STRCHR) QUOTE))
- (define-peg-pattern condition-var all (+ (or (range #\a #\z) "-" ":")))
- (define* (get-opam-repository #:optional repo)
- "Update or fetch the latest version of the opam repository and return the
- path to the repository."
- (let ((url (cond
- ((or (not repo) (equal? repo 'opam))
- "https://github.com/ocaml/opam-repository")
- ((string-prefix? "coq-" (symbol->string repo))
- "https://github.com/coq/opam-coq-archive")
- ((equal? repo 'coq) "https://github.com/coq/opam-coq-archive")
- (else (throw 'unknown-repository repo)))))
- (receive (location commit _)
- (update-cached-checkout url)
- (cond
- ((or (not repo) (equal? repo 'opam))
- location)
- ((equal? repo 'coq)
- (string-append location "/released"))
- ((string-prefix? "coq-" (symbol->string repo))
- (string-append location "/" (substring (symbol->string repo) 4)))
- (else location)))))
- ;; Prevent Guile 3 from inlining this procedure so we can mock it in tests.
- (set! get-opam-repository get-opam-repository)
- (define (latest-version versions)
- "Find the most recent version from a list of versions."
- (fold (lambda (a b) (if (version>? a b) a b)) (car versions) versions))
- (define (find-latest-version package repository)
- "Get the latest version of a package as described in the given repository."
- (let* ((dir (string-append repository "/packages/" package))
- (versions (scandir dir (lambda (name) (not (string-prefix? "." name))))))
- (if versions
- (let ((versions (map
- (lambda (dir)
- (string-join (cdr (string-split dir #\.)) "."))
- versions)))
- ;; Workaround for janestreet re-versionning
- (let ((v-versions (filter (lambda (version) (string-prefix? "v" version)) versions)))
- (if (null? v-versions)
- (latest-version versions)
- (string-append "v" (latest-version (map (lambda (version) (substring version 1)) v-versions))))))
- (begin
- (format #t (G_ "Package not found in opam repository: ~a~%") package)
- #f))))
- (define (get-metadata opam-file)
- (with-input-from-file opam-file
- (lambda _
- (peg:tree (match-pattern records (get-string-all (current-input-port)))))))
- (define (substitute-char str what with)
- (string-join (string-split str what) with))
- (define (ocaml-name->guix-name name)
- (substitute-char
- (cond
- ((equal? name "ocamlfind") "ocaml-findlib")
- ((equal? name "coq") name)
- ((string-prefix? "ocaml" name) name)
- ((string-prefix? "conf-" name) (substring name 5))
- (else (string-append "ocaml-" name)))
- #\_ "-"))
- (define (metadata-ref file lookup)
- (fold (lambda (record acc)
- (match record
- ((record key val)
- (if (equal? key lookup)
- (match val
- (('list-pat . stuff) stuff)
- (('string-pat stuff) stuff)
- (('multiline-string stuff) stuff)
- (('dict records ...) records))
- acc))))
- #f file))
- (define (native? condition)
- (match condition
- (('condition-var var)
- (match var
- ("with-test" #t)
- ("test" #t)
- ("build" #t)
- (_ #f)))
- ((or ('condition-or cond-left cond-right) ('condition-and cond-left cond-right))
- (or (native? cond-left)
- (native? cond-right)))
- (_ #f)))
- (define (dependency->input dependency)
- (match dependency
- (('string-pat str) str)
- ;; Arbitrary select the first dependency
- (('choice-pat choice ...) (dependency->input (car choice)))
- (('group-pat val ...) (map dependency->input val))
- (('conditional-value val condition)
- (if (native? condition) "" (dependency->input val)))))
- (define (dependency->native-input dependency)
- (match dependency
- (('string-pat str) "")
- ;; Arbitrary select the first dependency
- (('choice-pat choice ...) (dependency->native-input (car choice)))
- (('group-pat val ...) (map dependency->native-input val))
- (('conditional-value val condition)
- (if (native? condition) (dependency->input val) ""))))
- (define (dependency->name dependency)
- (match dependency
- (('string-pat str) str)
- ;; Arbitrary select the first dependency
- (('choice-pat choice ...) (dependency->name (car choice)))
- (('group-pat val ...) (map dependency->name val))
- (('conditional-value val condition)
- (dependency->name val))))
- (define (dependency-list->names lst)
- (filter
- (lambda (name)
- (not (or
- (string-prefix? "conf-" name)
- (equal? name "ocaml")
- (equal? name "findlib"))))
- (map dependency->name lst)))
- (define (ocaml-names->guix-names names)
- (map ocaml-name->guix-name
- (remove (lambda (name)
- (or (equal? "" name))
- (equal? "ocaml" name))
- names)))
- (define (filter-dependencies depends)
- "Remove implicit dependencies from the list of dependencies in @var{depends}."
- (filter (lambda (name)
- (and (not (member name '("" "ocaml" "ocamlfind" "dune" "jbuilder")))
- (not (string-prefix? "base-" name))))
- depends))
- (define (depends->inputs depends)
- (filter-dependencies (map dependency->input depends)))
- (define (depends->native-inputs depends)
- (filter (lambda (name) (not (equal? "" name)))
- (map dependency->native-input depends)))
- (define (dependency-list->inputs lst)
- (map
- (lambda (dependency)
- (list dependency (list 'unquote (string->symbol dependency))))
- (ocaml-names->guix-names lst)))
- (define* (opam-fetch name #:optional (repository (get-opam-repository)))
- (and-let* ((repository repository)
- (version (find-latest-version name repository))
- (file (string-append repository "/packages/" name "/" name "." version "/opam")))
- `(("metadata" ,@(get-metadata file))
- ("version" . ,(if (string-prefix? "v" version)
- (substring version 1)
- version)))))
- (define* (opam->guix-package name #:key (repo 'opam) version)
- "Import OPAM package NAME from REPOSITORY (a directory name) or, if
- REPOSITORY is #f, from the official OPAM repository. Return a 'package' sexp
- or #f on failure."
- (and-let* ((opam-file (opam-fetch name (get-opam-repository repo)))
- (version (assoc-ref opam-file "version"))
- (opam-content (assoc-ref opam-file "metadata"))
- (url-dict (metadata-ref opam-content "url"))
- (source-url (or (metadata-ref url-dict "src")
- (metadata-ref url-dict "archive")))
- (requirements (metadata-ref opam-content "depends"))
- (names (dependency-list->names requirements))
- (dependencies (filter-dependencies names))
- (native-dependencies (depends->native-inputs requirements))
- (inputs (dependency-list->inputs (depends->inputs requirements)))
- (native-inputs (dependency-list->inputs
- ;; Do not add dune nor jbuilder since they are
- ;; implicit inputs of the dune-build-system.
- (filter
- (lambda (name)
- (not (member name '("dune" "jbuilder"))))
- native-dependencies))))
- (let ((use-dune? (member "dune" names)))
- (call-with-temporary-output-file
- (lambda (temp port)
- (and (url-fetch source-url temp)
- (values
- `(package
- (name ,(ocaml-name->guix-name name))
- (version ,(if (string-prefix? "v" version)
- (substring version 1)
- version))
- (source
- (origin
- (method url-fetch)
- (uri ,source-url)
- (sha256 (base32 ,(guix-hash-url temp)))))
- (build-system ,(if use-dune?
- 'dune-build-system
- 'ocaml-build-system))
- ,@(if (null? inputs)
- '()
- `((propagated-inputs ,(list 'quasiquote inputs))))
- ,@(if (null? native-inputs)
- '()
- `((native-inputs ,(list 'quasiquote native-inputs))))
- ,@(if (equal? name (guix-name->opam-name (ocaml-name->guix-name name)))
- '()
- `((properties
- ,(list 'quasiquote `((upstream-name . ,name))))))
- (home-page ,(metadata-ref opam-content "homepage"))
- (synopsis ,(metadata-ref opam-content "synopsis"))
- (description ,(metadata-ref opam-content "description"))
- (license ,(spdx-string->license
- (metadata-ref opam-content "license"))))
- (filter
- (lambda (name)
- (not (member name '("dune" "jbuilder"))))
- dependencies))))))))
- (define* (opam-recursive-import package-name #:key repo)
- (recursive-import package-name
- #:repo->guix-package opam->guix-package
- #:guix-name ocaml-name->guix-name
- #:repo repo))
- (define (guix-name->opam-name name)
- (if (string-prefix? "ocaml-" name)
- (substring name 6)
- name))
- (define (guix-package->opam-name package)
- "Given an OCaml PACKAGE built from OPAM, return the name of the
- package in OPAM."
- (let ((upstream-name (assoc-ref
- (package-properties package)
- 'upstream-name))
- (name (package-name package)))
- (if upstream-name
- upstream-name
- (guix-name->opam-name name))))
- (define (opam-package? package)
- "Return true if PACKAGE is an OCaml package from OPAM"
- (and
- (member (build-system-name (package-build-system package)) '(dune ocaml))
- (not (string-prefix? "ocaml4" (package-name package)))))
- (define (latest-release package)
- "Return an <upstream-source> for the latest release of PACKAGE."
- (and-let* ((opam-name (guix-package->opam-name package))
- (opam-file (opam-fetch opam-name))
- (version (assoc-ref opam-file "version"))
- (opam-content (assoc-ref opam-file "metadata"))
- (url-dict (metadata-ref opam-content "url"))
- (source-url (metadata-ref url-dict "src")))
- (upstream-source
- (package (package-name package))
- (version version)
- (urls (list source-url)))))
- (define %opam-updater
- (upstream-updater
- (name 'opam)
- (description "Updater for OPAM packages")
- (pred opam-package?)
- (latest latest-release)))
|