diff options
| -rw-r--r-- | guix/import/opam.scm | 305 | ||||
| -rw-r--r-- | po/guix/POTFILES.in | 1 | ||||
| -rw-r--r-- | tests/opam.scm | 225 |
3 files changed, 321 insertions, 210 deletions
diff --git a/guix/import/opam.scm b/guix/import/opam.scm index f252bdc31a..c42a5d767d 100644 --- a/guix/import/opam.scm +++ b/guix/import/opam.scm @@ -17,132 +17,108 @@ ;;; 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 vlist) + #: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 http-client) + #:use-module (guix git) + #:use-module (guix ui) #:use-module (guix utils) #:use-module (guix import utils) #:use-module ((guix licenses) #:prefix license:) #:export (opam->guix-package)) -(define (opam-urls) - "Fetch the urls.txt file from the opam repository and returns the list of -URLs it contains." - (let ((port (http-fetch/cached (string->uri "https://opam.ocaml.org/urls.txt")))) - (let loop ((result '())) - (let ((line (read-line port))) - (if (eof-object? line) - (begin - (close port) - result) - (loop (cons line result))))))) - -(define (vhash-ref hashtable key default) - (match (vhash-assoc key hashtable) - (#f default) - ((_ . x) x))) - -(define (hashtable-update hashtable line) - "Parse @var{line} to get the name and version of the package and adds them -to the hashtable." - (let* ((line (string-split line #\ ))) - (match line - ((url foo ...) - (if (equal? url "repo") - hashtable - (match (string-split url #\/) - ((type name1 versionstr foo ...) - (if (equal? type "packages") - (match (string-split versionstr #\.) - ((name2 versions ...) - (let ((version (string-join versions "."))) - (if (equal? name1 name2) - (let ((curr (vhash-ref hashtable name1 '()))) - (vhash-cons name1 (cons version curr) hashtable)) - hashtable))) - (_ hashtable)) - hashtable)) - (_ hashtable)))) - (_ hashtable)))) - -(define (urls->hashtable urls) - "Transform urls.txt in a hashtable whose keys are package names and values -the list of available versions." - (let ((hashtable vlist-null)) - (let loop ((urls urls) (hashtable hashtable)) - (match urls - (() hashtable) - ((url rest ...) (loop rest (hashtable-update hashtable url))))))) +;; Define a PEG parser for the opam format +(define-peg-pattern SP none (or " " "\n")) +(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 STRCHR body + (or " " "!" (and (ignore "\\") "\"") + (and (ignore "\\") "\\") (range #\# #\頋))) +(define-peg-pattern operator all (or "=" "!" "<" ">")) + +(define-peg-pattern records body (* (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 ground-value body (and (or multiline-string string-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-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-content body (or condition-string condition-var)) +(define-peg-pattern condition-content2 body (and condition-content (* SP) (not-followed-by (or "&" "=" "!")))) +(define-peg-pattern condition-string all (and QUOTE (* STRCHR) QUOTE)) +(define-peg-pattern condition-var all (+ (or (range #\a #\z) "-"))) + +(define (get-opam-repository) + "Update or fetch the latest version of the opam repository and return the +path to the repository." + (receive (location commit) + (update-cached-checkout "https://github.com/ocaml/opam-repository") + location)) (define (latest-version versions) "Find the most recent version from a list of versions." - (match versions - ((first rest ...) - (let loop ((versions rest) (m first)) - (match versions - (() m) - ((first rest ...) - (loop rest (if (version>? m first) m first)))))))) - -(define (fetch-package-url uri) - "Fetch and parse the url file. Return the URL the package can be downloaded -from." - (let ((port (http-fetch uri))) - (let loop ((result #f)) - (let ((line (read-line port))) - (if (eof-object? line) - (begin - (close port) - result) - (let* ((line (string-split line #\ ))) - (match line - ((key value rest ...) - (if (member key '("archive:" "http:")) - (loop (string-trim-both value #\")) - (loop result)))))))))) - -(define (fetch-package-metadata uri) - "Fetch and parse the opam file. Return an association list containing the -homepage, the license and the list of inputs." - (let ((port (http-fetch uri))) - (let loop ((result '()) (dependencies? #f)) - (let ((line (read-line port))) - (if (eof-object? line) - (begin - (close port) - result) - (let* ((line (string-split line #\ ))) - (match line - ((key value ...) - (let ((dependencies? - (if dependencies? - (not (equal? key "]")) - (equal? key "depends:"))) - (val (string-trim-both (string-join value "") #\"))) - (cond - ((equal? key "homepage:") - (loop (cons `("homepage" . ,val) result) dependencies?)) - ((equal? key "license:") - (loop (cons `("license" . ,val) result) dependencies?)) - ((and dependencies? (not (equal? val "["))) - (match (string-split val #\{) - ((val rest ...) - (let ((curr (assoc-ref result "inputs")) - (new (string-trim-both - val (list->char-set '(#\] #\[ #\"))))) - (loop (cons `("inputs" . ,(cons new (if curr curr '()))) result) - (if (string-contains val "]") #f dependencies?)))))) - (else (loop result dependencies?)))))))))))) - -(define (string->license str) - (cond - ((equal? str "MIT") '(license:expat)) - ((equal? str "GPL2") '(license:gpl2)) - ((equal? str "LGPLv2") '(license:lgpl2)) - (else `()))) + (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))) + (latest-version 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 (ocaml-name->guix-name name) (cond @@ -151,33 +127,85 @@ homepage, the license and the list of inputs." ((string-prefix? "conf-" name) (substring name 5)) (else (string-append "ocaml-" name)))) -(define (dependencies->inputs dependencies) - "Transform the list of dependencies in a list of inputs." - (if (not dependencies) - '() - (map (lambda (input) - (list input (list 'unquote (string->symbol input)))) - (map ocaml-name->guix-name dependencies)))) +(define (metadata-ref file lookup) + (pk 'file file 'lookup 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) + (('conditional-value val condition) + (if (native? condition) "" (dependency->input val))))) + +(define (dependency->native-input dependency) + (match dependency + (('string-pat str) "") + (('conditional-value val condition) + (if (native? condition) (dependency->input val) "")))) + +(define (ocaml-names->guix-names names) + (map ocaml-name->guix-name + (remove (lambda (name) + (or (equal? "" name)) + (equal? "ocaml" name)) + names))) + +(define (depends->inputs depends) + (filter (lambda (name) + (and (not (equal? "" name)) + (not (equal? "ocaml" name)) + (not (equal? "ocamlfind" name)))) + (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->guix-package name) - (let* ((hashtable (urls->hashtable (opam-urls))) - (versions (vhash-ref hashtable name #f))) - (unless (eq? versions #f) - (let* ((version (latest-version versions)) - (package-url (string-append "https://opam.ocaml.org/packages/" name - "/" name "." version "/")) - (url-url (string-append package-url "url")) - (opam-url (string-append package-url "opam")) - (source-url (fetch-package-url url-url)) - (metadata (fetch-package-metadata opam-url)) - (dependencies (assoc-ref metadata "inputs")) - (inputs (dependencies->inputs dependencies))) + (and-let* ((repository (get-opam-repository)) + (version (find-latest-version name repository)) + (file (string-append repository "/packages/" name "/" name "." (pk 'version version) "/opam")) + (opam-content (get-metadata file)) + (url-dict (metadata-ref (pk 'metadata opam-content) "url")) + (source-url (metadata-ref url-dict "src")) + (requirements (metadata-ref opam-content "depends")) + (inputs (dependency-list->inputs (depends->inputs requirements))) + (native-inputs (dependency-list->inputs (depends->native-inputs requirements)))) (call-with-temporary-output-file (lambda (temp port) (and (url-fetch source-url temp) `(package (name ,(ocaml-name->guix-name name)) - (version ,version) + (version ,(metadata-ref opam-content "version")) (source (origin (method url-fetch) @@ -187,7 +215,10 @@ homepage, the license and the list of inputs." ,@(if (null? inputs) '() `((inputs ,(list 'quasiquote inputs)))) - (home-page ,(assoc-ref metadata "homepage")) - (synopsis "") - (description "") - (license ,@(string->license (assoc-ref metadata "license"))))))))))) + ,@(if (null? native-inputs) + '() + `((native-inputs ,(list 'quasiquote native-inputs)))) + (home-page ,(metadata-ref opam-content "homepage")) + (synopsis ,(metadata-ref opam-content "synopsis")) + (description ,(metadata-ref opam-content "description")) + (license #f))))))) diff --git a/po/guix/POTFILES.in b/po/guix/POTFILES.in index e0da801587..c432973f9e 100644 --- a/po/guix/POTFILES.in +++ b/po/guix/POTFILES.in @@ -7,6 +7,7 @@ gnu/system.scm gnu/services/shepherd.scm gnu/system/mapped-devices.scm gnu/system/shadow.scm +guix/import/opam.scm guix/scripts.scm guix/scripts/build.scm guix/discovery.scm diff --git a/tests/opam.scm b/tests/opam.scm index a1320abfdc..e0ec5ef3d4 100644 --- a/tests/opam.scm +++ b/tests/opam.scm @@ -21,98 +21,177 @@ #:use-module (guix base32) #:use-module (gcrypt hash) #:use-module (guix tests) + #:use-module ((guix build syscalls) #:select (mkdtemp!)) #:use-module ((guix build utils) #:select (delete-file-recursively mkdir-p which)) + #:use-module ((guix utils) #:select (call-with-temporary-output-file)) + #:use-module (srfi srfi-1) #:use-module (srfi srfi-64) #:use-module (web uri) - #:use-module (ice-9 match)) - -(define test-url-file - "http: \"https://example.org/foo-1.0.0.tar.gz\" -checksum: \"ac8920f39a8100b94820659bc2c20817\"") - -(define test-source-hash - "") - -(define test-urls - "repo ac8920f39a8100b94820659bc2c20817 0o644 -packages/foo/foo.1.0.0/url ac8920f39a8100b94820659bc2c20817 0o644 -packages/foo/foo.1.0.0/opam ac8920f39a8100b94820659bc2c20817 0o644 -packages/foo/foo.1.0.0/descr ac8920f39a8100b94820659bc2c20817 0o644") + #:use-module (ice-9 match) + #:use-module (ice-9 peg)) (define test-opam-file -"opam-version: 1.2 +"opam-version: \"2.0\" + version: \"1.0.0\" maintainer: \"Alice Doe\" -authors: \"Alice Doe, John Doe\" +authors: [ + \"Alice Doe\" + \"John Doe\" +] homepage: \"https://example.org/\" bug-reports: \"https://example.org/bugs\" -license: \"MIT\" dev-repo: \"https://example.org/git\" build: [ - \"ocaml\" \"pkg/pkg.ml\" \"build\" \"--pinned\" \"%{pinned}%\" + [\"ocaml\" \"pkg/pkg.ml\" \"build\" \"--pinned\" \"%{pinned}%\"] ] build-test: [ - \"ocaml\" \"pkg/pkg.ml\" \"build\" \"--pinned\" \"%{pinned}%\" \"--tests\" \"true\" + [\"ocaml\" \"pkg/pkg.ml\" \"build\" \"--pinned\" \"%{pinned}%\" \"--tests\" \"true\"] ] depends: [ \"alcotest\" {test & >= \"0.7.2\"} \"ocamlbuild\" {build & >= \"0.9.2\"} -]") + \"zarith\" {>= \"0.7\"} +] +synopsis: \"Some example package\" +description: \"\"\" +This package is just an example.\"\"\" +url { + src: \"https://example.org/foo-1.0.0.tar.gz\" + checksum: \"md5=74c6e897658e820006106f45f736381f\" +}") + +(define test-source-hash + "") + +(define test-repo + (mkdtemp! "/tmp/opam-repo.XXXXXX")) (test-begin "opam") (test-assert "opam->guix-package" - ;; Replace network resources with sample data. - (mock ((guix import utils) url-fetch - (lambda (url file-name) - (match url - ("https://example.org/foo-1.0.0.tar.gz" - (begin - (mkdir-p "foo-1.0.0") - (system* "tar" "czvf" file-name "foo-1.0.0/") - (delete-file-recursively "foo-1.0.0") - (set! test-source-hash - (call-with-input-file file-name port-sha256)))) - (_ (error "Unexpected URL: " url))))) - (mock ((guix http-client) http-fetch/cached - (lambda (url . rest) - (match (uri->string url) - ("https://opam.ocaml.org/urls.txt" - (values (open-input-string test-urls) - (string-length test-urls))) - (_ (error "Unexpected URL: " url))))) - (mock ((guix http-client) http-fetch - (lambda (url . rest) - (match url - ("https://opam.ocaml.org/packages/foo/foo.1.0.0/url" - (values (open-input-string test-url-file) - (string-length test-url-file))) - ("https://opam.ocaml.org/packages/foo/foo.1.0.0/opam" - (values (open-input-string test-opam-file) - (string-length test-opam-file))) - (_ (error "Unexpected URL: " url))))) - (match (opam->guix-package "foo") - (('package - ('name "ocaml-foo") - ('version "1.0.0") - ('source ('origin - ('method 'url-fetch) - ('uri "https://example.org/foo-1.0.0.tar.gz") - ('sha256 - ('base32 - (? string? hash))))) - ('build-system 'ocaml-build-system) - ('inputs - ('quasiquote - (("ocamlbuild" ('unquote 'ocamlbuild)) - ("ocaml-alcotest" ('unquote 'ocaml-alcotest))))) - ('home-page "https://example.org/") - ('synopsis "") - ('description "") - ('license 'license:expat)) - (string=? (bytevector->nix-base32-string - test-source-hash) - hash)) - (x - (pk 'fail x #f))))))) + (mock ((guix import utils) url-fetch + (lambda (url file-name) + (match url + ("https://example.org/foo-1.0.0.tar.gz" + (begin + (mkdir-p "foo-1.0.0") + (system* "tar" "czvf" file-name "foo-1.0.0/") + (delete-file-recursively "foo-1.0.0") + (set! test-source-hash + (call-with-input-file file-name port-sha256)))) + (_ (error "Unexpected URL: " url))))) + (let ((my-package (string-append test-repo "/packages/foo/foo.1.0.0"))) + (mkdir-p my-package) + (with-output-to-file (string-append my-package "/opam") + (lambda _ + (format #t "~a" test-opam-file)))) + (mock ((guix import opam) get-opam-repository + (lambda _ + test-repo)) + (match (opam->guix-package "foo") + (('package + ('name "ocaml-foo") + ('version "1.0.0") + ('source ('origin + ('method 'url-fetch) + ('uri "https://example.org/foo-1.0.0.tar.gz") + ('sha256 + ('base32 + (? string? hash))))) + ('build-system 'ocaml-build-system) + ('inputs + ('quasiquote + (("ocaml-zarith" ('unquote 'ocaml-zarith))))) + ('native-inputs + ('quasiquote + (("ocaml-alcotest" ('unquote 'ocaml-alcotest)) + ("ocamlbuild" ('unquote 'ocamlbuild))))) + ('home-page "https://example.org/") + ('synopsis "Some example package") + ('description "This package is just an example.") + ('license #f)) + (string=? (bytevector->nix-base32-string + test-source-hash) + hash)) + (x + (pk 'fail x #f)))))) + +;; Test the opam file parser +;; We fold over some test cases. Each case is a pair of the string to parse and the +;; expected result. +(test-assert "parse-strings" + (fold (lambda (test acc) + (display test) (newline) + (and acc + (let ((result (peg:tree (match-pattern (@@ (guix import opam) string-pat) (car test))))) + (if (equal? result (cdr test)) + #t + (pk 'fail (list (car test) result (cdr test)) #f))))) + #t '(("" . #f) + ("\"hello\"" . (string-pat "hello")) + ("\"hello world\"" . (string-pat "hello world")) + ("\"The dreaded \\\"é\\\"\"" . (string-pat "The dreaded \"é\"")) + ("\"Have some \\\\\\\\ :)\"" . (string-pat "Have some \\\\ :)")) + ("\"今日は\"" . (string-pat "今日は"))))) + +(test-assert "parse-multiline-strings" + (fold (lambda (test acc) + (display test) (newline) + (and acc + (let ((result (peg:tree (match-pattern (@@ (guix import opam) multiline-string) (car test))))) + (if (equal? result (cdr test)) + #t + (pk 'fail (list (car test) result (cdr test)) #f))))) + #t '(("" . #f) + ("\"\"\"hello\"\"\"" . (multiline-string "hello")) + ("\"\"\"hello \"world\"!\"\"\"" . (multiline-string "hello \"world\"!")) + ("\"\"\"hello \"\"world\"\"!\"\"\"" . (multiline-string "hello \"\"world\"\"!"))))) + +(test-assert "parse-lists" + (fold (lambda (test acc) + (and acc + (let ((result (peg:tree (match-pattern (@@ (guix import opam) list-pat) (car test))))) + (if (equal? result (cdr test)) + #t + (pk 'fail (list (car test) result (cdr test)) #f))))) + #t '(("" . #f) + ("[]" . list-pat) + ("[make]" . (list-pat (var "make"))) + ("[\"make\"]" . (list-pat (string-pat "make"))) + ("[\n a\n b\n c]" . (list-pat (var "a") (var "b") (var "c"))) + ("[a b \"c\"]" . (list-pat (var "a") (var "b") (string-pat "c")))))) + +(test-assert "parse-dicts" + (fold (lambda (test acc) + (and acc + (let ((result (peg:tree (match-pattern (@@ (guix import opam) dict) (car test))))) + (if (equal? result (cdr test)) + #t + (pk 'fail (list (car test) result (cdr test)) #f))))) + #t '(("" . #f) + ("{}" . dict) + ("{a: \"b\"}" . (dict (record "a" (string-pat "b")))) + ("{a: \"b\"\nc: \"d\"}" . (dict (record "a" (string-pat "b")) (record "c" (string-pat "d"))))))) + +(test-assert "parse-conditions" + (fold (lambda (test acc) + (and acc + (let ((result (peg:tree (match-pattern (@@ (guix import opam) condition) (car test))))) + (if (equal? result (cdr test)) + #t + (pk 'fail (list (car test) result (cdr test)) #f))))) + #t '(("" . #f) + ("{}" . #f) + ("{build}" . (condition-var "build")) + ("{>= \"0.2.0\"}" . (condition-greater-or-equal + (condition-string "0.2.0"))) + ("{>= \"0.2.0\" & test}" . (condition-and + (condition-greater-or-equal + (condition-string "0.2.0")) + (condition-var "test"))) + ("{>= \"0.2.0\" | build}" . (condition-or + (condition-greater-or-equal + (condition-string "0.2.0")) + (condition-var "build")))))) (test-end "opam") |