import: Update opam importer.

* guix/import/opam.scm: Update importer for opam 2.
* tests/opam.scm: Update tests for the opam 2 importer.

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)
+;; Define a PEG parser for the opam format
-  "Fetch the urls.txt file from the opam repository and returns the list of
+(define-peg-pattern SP none (or " " "\n"))
-URLs it contains."
+(define-peg-pattern SP2 body (or " " "\n"))
-  (let ((port (http-fetch/cached (string->uri "https://opam.ocaml.org/urls.txt"))))
+(define-peg-pattern QUOTE none "\"")
-    (let loop ((result '()))
+(define-peg-pattern QUOTE2 body "\"")
-      (let ((line (read-line port)))
+(define-peg-pattern COLON none ":")
-        (if (eof-object? line)
+;; A string character is any character that is not a quote, or a quote preceded by a backslash.
-          (begin
+(define-peg-pattern STRCHR body
-            (close port)
+                    (or " " "!" (and (ignore "\\") "\"")
-            result)
+                        (and (ignore "\\") "\\") (range #\# #\頋)))
-          (loop (cons line result)))))))
+(define-peg-pattern operator all (or "=" "!" "<" ">"))
 
-(define (vhash-ref hashtable key default)
+(define-peg-pattern records body (* (and (or record weird-record) (* SP))))
-  (match (vhash-assoc key hashtable)
+(define-peg-pattern record all (and key COLON (* SP) value))
-    (#f default)
+(define-peg-pattern weird-record all (and key (* SP) dict))
-    ((_ . x) x)))
+(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 (hashtable-update hashtable line)
+(define-peg-pattern condition body (and (ignore "{") condition-form (ignore "}")))
-  "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)
+(define-peg-pattern condition-form body
-  "Transform urls.txt in a hashtable whose keys are package names and values
+                    (and
-the list of available versions."
+                      (* SP)
-  (let ((hashtable vlist-null))
+                      (or condition-and condition-or condition-form2)
-    (let loop ((urls urls) (hashtable hashtable))
+                      (* SP)))
-      (match urls
+(define-peg-pattern condition-form2 body
-        (() hashtable)
+                    (and (* SP) (or condition-greater-or-equal condition-greater
-        ((url rest ...) (loop rest (hashtable-update hashtable url)))))))
+                                    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
+  (fold (lambda (a b) (if (version>? a b) a b)) (car versions) 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)
+(define (find-latest-version package repository)
-  "Fetch and parse the url file.  Return the URL the package can be downloaded
+  "Get the latest version of a package as described in the given repository."
-from."
+  (let* ((dir (string-append repository "/packages/" package))
-  (let ((port (http-fetch uri)))
+         (versions (scandir dir (lambda (name) (not (string-prefix? "." name))))))
-    (let loop ((result #f))
+    (if versions
-      (let ((line (read-line port)))
+      (let ((versions (map
-        (if (eof-object? line)
+                        (lambda (dir)
+                          (string-join (cdr (string-split dir #\.)) "."))
+                        versions)))
+        (latest-version versions))
       (begin
-            (close port)
+        (format #t (G_ "Package not found in opam repository: ~a~%") package)
-            result)
+        #f))))
-          (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)
+(define (get-metadata opam-file)
-  "Fetch and parse the opam file.  Return an association list containing the
+  (with-input-from-file opam-file
-homepage, the license and the list of inputs."
+    (lambda _
-  (let ((port (http-fetch uri)))
+      (peg:tree (match-pattern records (get-string-all (current-input-port)))))))
-    (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 `())))
 
 (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)
+(define (metadata-ref file lookup)
-  "Transform the list of dependencies in a list of inputs."
+  (pk 'file file 'lookup lookup)
-  (if (not dependencies)
+  (fold (lambda (record acc)
-    '()
+          (match record
-    (map (lambda (input)
+            ((record key val)
-           (list input (list 'unquote (string->symbol input))))
+             (if (equal? key lookup)
-         (map ocaml-name->guix-name dependencies))))
+               (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)))
+  (and-let* ((repository (get-opam-repository))
-         (versions (vhash-ref hashtable name #f)))
+             (version (find-latest-version name repository))
-    (unless (eq? versions #f)
+             (file (string-append repository "/packages/" name "/" name "." (pk 'version version) "/opam"))
-      (let* ((version (latest-version versions))
+             (opam-content (get-metadata file))
-             (package-url (string-append "https://opam.ocaml.org/packages/" name
+             (url-dict (metadata-ref (pk 'metadata opam-content) "url"))
-                                         "/" name "." version "/"))
+             (source-url (metadata-ref url-dict "src"))
-             (url-url (string-append package-url "url"))
+             (requirements (metadata-ref opam-content "depends"))
-             (opam-url (string-append package-url "opam"))
+             (inputs (dependency-list->inputs (depends->inputs requirements)))
-             (source-url (fetch-package-url url-url))
+             (native-inputs (dependency-list->inputs (depends->native-inputs requirements))))
-             (metadata (fetch-package-metadata opam-url))
-             (dependencies (assoc-ref metadata "inputs"))
-             (inputs (dependencies->inputs dependencies)))
         (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"))
+                    ,@(if (null? native-inputs)
-                    (synopsis "")
+                        '()
-                    (description "")
+                        `((native-inputs ,(list 'quasiquote native-inputs))))
-                    (license ,@(string->license (assoc-ref metadata "license")))))))))))
+                    (home-page ,(metadata-ref opam-content "homepage"))
+                    (synopsis ,(metadata-ref opam-content "synopsis"))
+                    (description ,(metadata-ref opam-content "description"))
+                    (license #f)))))))

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

tests/opam.scm

@@ -21,47 +21,54 @@
   #: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))
+  #:use-module (ice-9 match)
-
+  #:use-module (ice-9 peg))
-(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")
 
 (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
@@ -73,23 +80,14 @@ depends: [
                 (set! test-source-hash
                   (call-with-input-file file-name port-sha256))))
              (_ (error "Unexpected URL: " url)))))
-          (mock ((guix http-client) http-fetch/cached
+      (let ((my-package (string-append test-repo "/packages/foo/foo.1.0.0")))
-                 (lambda (url . rest)
+        (mkdir-p my-package)
-                   (match (uri->string url)
+        (with-output-to-file (string-append my-package "/opam")
-                     ("https://opam.ocaml.org/urls.txt"
+          (lambda _
-                      (values (open-input-string test-urls)
+            (format #t "~a" test-opam-file))))
-                              (string-length test-urls)))
+      (mock ((guix import opam) get-opam-repository
-                     (_ (error "Unexpected URL: " url)))))
+             (lambda _
-                (mock ((guix http-client) http-fetch
+               test-repo))
-                       (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")
@@ -103,16 +101,97 @@ depends: [
              ('build-system 'ocaml-build-system)
              ('inputs
               ('quasiquote
-                             (("ocamlbuild" ('unquote 'ocamlbuild))
+               (("ocaml-zarith" ('unquote 'ocaml-zarith)))))
-                              ("ocaml-alcotest" ('unquote 'ocaml-alcotest)))))
+             ('native-inputs
+              ('quasiquote
+               (("ocaml-alcotest" ('unquote 'ocaml-alcotest))
+                ("ocamlbuild" ('unquote 'ocamlbuild)))))
              ('home-page "https://example.org/")
-                           ('synopsis "")
+             ('synopsis "Some example package")
-                           ('description "")
+             ('description "This package is just an example.")
-                           ('license 'license:expat))
+             ('license #f))
            (string=? (bytevector->nix-base32-string
                       test-source-hash)
                      hash))
           (x
-                         (pk 'fail x #f)))))))
+           (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")