| 1 | ;;; GNU Guix --- Functional package management for GNU |
| 2 | ;;; Copyright © 2018 Julien Lepiller <julien@lepiller.eu> |
| 3 | ;;; |
| 4 | ;;; This file is part of GNU Guix. |
| 5 | ;;; |
| 6 | ;;; GNU Guix is free software; you can redistribute it and/or modify it |
| 7 | ;;; under the terms of the GNU General Public License as published by |
| 8 | ;;; the Free Software Foundation; either version 3 of the License, or (at |
| 9 | ;;; your option) any later version. |
| 10 | ;;; |
| 11 | ;;; GNU Guix is distributed in the hope that it will be useful, but |
| 12 | ;;; WITHOUT ANY WARRANTY; without even the implied warranty of |
| 13 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
| 14 | ;;; GNU General Public License for more details. |
| 15 | ;;; |
| 16 | ;;; You should have received a copy of the GNU General Public License |
| 17 | ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. |
| 18 | |
| 19 | (define-module (test-opam) |
| 20 | #:use-module (guix import opam) |
| 21 | #:use-module (guix base32) |
| 22 | #:use-module (gcrypt hash) |
| 23 | #:use-module (guix tests) |
| 24 | #:use-module ((guix build syscalls) #:select (mkdtemp!)) |
| 25 | #:use-module ((guix build utils) #:select (delete-file-recursively mkdir-p which)) |
| 26 | #:use-module ((guix utils) #:select (call-with-temporary-output-file)) |
| 27 | #:use-module (srfi srfi-1) |
| 28 | #:use-module (srfi srfi-64) |
| 29 | #:use-module (web uri) |
| 30 | #:use-module (ice-9 match) |
| 31 | #:use-module (ice-9 peg)) |
| 32 | |
| 33 | (define test-opam-file |
| 34 | "opam-version: \"2.0\" |
| 35 | version: \"1.0.0\" |
| 36 | maintainer: \"Alice Doe\" |
| 37 | authors: [ |
| 38 | \"Alice Doe\" |
| 39 | \"John Doe\" |
| 40 | ] |
| 41 | homepage: \"https://example.org/\" |
| 42 | bug-reports: \"https://example.org/bugs\" |
| 43 | dev-repo: \"https://example.org/git\" |
| 44 | build: [ |
| 45 | [\"ocaml\" \"pkg/pkg.ml\" \"build\" \"--pinned\" \"%{pinned}%\"] |
| 46 | ] |
| 47 | build-test: [ |
| 48 | [\"ocaml\" \"pkg/pkg.ml\" \"build\" \"--pinned\" \"%{pinned}%\" \"--tests\" \"true\"] |
| 49 | ] |
| 50 | depends: [ |
| 51 | \"alcotest\" {test & >= \"0.7.2\"} |
| 52 | \"ocamlbuild\" {build & >= \"0.9.2\"} |
| 53 | \"zarith\" {>= \"0.7\"} |
| 54 | ] |
| 55 | synopsis: \"Some example package\" |
| 56 | description: \"\"\" |
| 57 | This package is just an example.\"\"\" |
| 58 | url { |
| 59 | src: \"https://example.org/foo-1.0.0.tar.gz\" |
| 60 | checksum: \"md5=74c6e897658e820006106f45f736381f\" |
| 61 | }") |
| 62 | |
| 63 | (define test-source-hash |
| 64 | "") |
| 65 | |
| 66 | (define test-repo |
| 67 | (mkdtemp! "/tmp/opam-repo.XXXXXX")) |
| 68 | |
| 69 | (test-begin "opam") |
| 70 | |
| 71 | (test-assert "opam->guix-package" |
| 72 | (mock ((guix import utils) url-fetch |
| 73 | (lambda (url file-name) |
| 74 | (match url |
| 75 | ("https://example.org/foo-1.0.0.tar.gz" |
| 76 | (begin |
| 77 | (mkdir-p "foo-1.0.0") |
| 78 | (system* "tar" "czvf" file-name "foo-1.0.0/") |
| 79 | (delete-file-recursively "foo-1.0.0") |
| 80 | (set! test-source-hash |
| 81 | (call-with-input-file file-name port-sha256)))) |
| 82 | (_ (error "Unexpected URL: " url))))) |
| 83 | (let ((my-package (string-append test-repo "/packages/foo/foo.1.0.0"))) |
| 84 | (mkdir-p my-package) |
| 85 | (with-output-to-file (string-append my-package "/opam") |
| 86 | (lambda _ |
| 87 | (format #t "~a" test-opam-file)))) |
| 88 | (match (opam->guix-package "foo" #:repository test-repo) |
| 89 | (('package |
| 90 | ('name "ocaml-foo") |
| 91 | ('version "1.0.0") |
| 92 | ('source ('origin |
| 93 | ('method 'url-fetch) |
| 94 | ('uri "https://example.org/foo-1.0.0.tar.gz") |
| 95 | ('sha256 |
| 96 | ('base32 |
| 97 | (? string? hash))))) |
| 98 | ('build-system 'ocaml-build-system) |
| 99 | ('propagated-inputs |
| 100 | ('quasiquote |
| 101 | (("ocaml-zarith" ('unquote 'ocaml-zarith))))) |
| 102 | ('native-inputs |
| 103 | ('quasiquote |
| 104 | (("ocaml-alcotest" ('unquote 'ocaml-alcotest)) |
| 105 | ("ocamlbuild" ('unquote 'ocamlbuild))))) |
| 106 | ('home-page "https://example.org/") |
| 107 | ('synopsis "Some example package") |
| 108 | ('description "This package is just an example.") |
| 109 | ('license #f)) |
| 110 | (string=? (bytevector->nix-base32-string |
| 111 | test-source-hash) |
| 112 | hash)) |
| 113 | (x |
| 114 | (pk 'fail x #f))))) |
| 115 | |
| 116 | ;; Test the opam file parser |
| 117 | ;; We fold over some test cases. Each case is a pair of the string to parse and the |
| 118 | ;; expected result. |
| 119 | (test-assert "parse-strings" |
| 120 | (fold (lambda (test acc) |
| 121 | (display test) (newline) |
| 122 | (and acc |
| 123 | (let ((result (peg:tree (match-pattern string-pat (car test))))) |
| 124 | (if (equal? result (cdr test)) |
| 125 | #t |
| 126 | (pk 'fail (list (car test) result (cdr test)) #f))))) |
| 127 | #t '(("" . #f) |
| 128 | ("\"hello\"" . (string-pat "hello")) |
| 129 | ("\"hello world\"" . (string-pat "hello world")) |
| 130 | ("\"The dreaded \\\"é\\\"\"" . (string-pat "The dreaded \"é\"")) |
| 131 | ("\"Have some \\\\\\\\ :)\"" . (string-pat "Have some \\\\ :)")) |
| 132 | ("\"今日は\"" . (string-pat "今日は"))))) |
| 133 | |
| 134 | (test-assert "parse-multiline-strings" |
| 135 | (fold (lambda (test acc) |
| 136 | (display test) (newline) |
| 137 | (and acc |
| 138 | (let ((result (peg:tree (match-pattern multiline-string (car test))))) |
| 139 | (if (equal? result (cdr test)) |
| 140 | #t |
| 141 | (pk 'fail (list (car test) result (cdr test)) #f))))) |
| 142 | #t '(("" . #f) |
| 143 | ("\"\"\"hello\"\"\"" . (multiline-string "hello")) |
| 144 | ("\"\"\"hello \"world\"!\"\"\"" . (multiline-string "hello \"world\"!")) |
| 145 | ("\"\"\"hello \"\"world\"\"!\"\"\"" . (multiline-string "hello \"\"world\"\"!"))))) |
| 146 | |
| 147 | (test-assert "parse-lists" |
| 148 | (fold (lambda (test acc) |
| 149 | (and acc |
| 150 | (let ((result (peg:tree (match-pattern list-pat (car test))))) |
| 151 | (if (equal? result (cdr test)) |
| 152 | #t |
| 153 | (pk 'fail (list (car test) result (cdr test)) #f))))) |
| 154 | #t '(("" . #f) |
| 155 | ("[]" . list-pat) |
| 156 | ("[make]" . (list-pat (var "make"))) |
| 157 | ("[\"make\"]" . (list-pat (string-pat "make"))) |
| 158 | ("[\n a\n b\n c]" . (list-pat (var "a") (var "b") (var "c"))) |
| 159 | ("[a b \"c\"]" . (list-pat (var "a") (var "b") (string-pat "c")))))) |
| 160 | |
| 161 | (test-assert "parse-dicts" |
| 162 | (fold (lambda (test acc) |
| 163 | (and acc |
| 164 | (let ((result (peg:tree (match-pattern dict (car test))))) |
| 165 | (if (equal? result (cdr test)) |
| 166 | #t |
| 167 | (pk 'fail (list (car test) result (cdr test)) #f))))) |
| 168 | #t '(("" . #f) |
| 169 | ("{}" . dict) |
| 170 | ("{a: \"b\"}" . (dict (record "a" (string-pat "b")))) |
| 171 | ("{a: \"b\"\nc: \"d\"}" . (dict (record "a" (string-pat "b")) (record "c" (string-pat "d"))))))) |
| 172 | |
| 173 | (test-assert "parse-conditions" |
| 174 | (fold (lambda (test acc) |
| 175 | (and acc |
| 176 | (let ((result (peg:tree (match-pattern condition (car test))))) |
| 177 | (if (equal? result (cdr test)) |
| 178 | #t |
| 179 | (pk 'fail (list (car test) result (cdr test)) #f))))) |
| 180 | #t '(("" . #f) |
| 181 | ("{}" . #f) |
| 182 | ("{build}" . (condition-var "build")) |
| 183 | ("{>= \"0.2.0\"}" . (condition-greater-or-equal |
| 184 | (condition-string "0.2.0"))) |
| 185 | ("{>= \"0.2.0\" & test}" . (condition-and |
| 186 | (condition-greater-or-equal |
| 187 | (condition-string "0.2.0")) |
| 188 | (condition-var "test"))) |
| 189 | ("{>= \"0.2.0\" | build}" . (condition-or |
| 190 | (condition-greater-or-equal |
| 191 | (condition-string "0.2.0")) |
| 192 | (condition-var "build"))) |
| 193 | ("{ = \"1.0+beta19\" }" . (condition-eq |
| 194 | (condition-string "1.0+beta19")))))) |
| 195 | |
| 196 | (test-end "opam") |