| 1 | ;;; GNU Guix --- Functional package management for GNU |
| 2 | ;;; Copyright © 2021 Maxime Devos <maximedevos@telenet.be> |
| 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-minetest) |
| 20 | #:use-module (guix memoization) |
| 21 | #:use-module (guix import minetest) |
| 22 | #:use-module (guix import utils) |
| 23 | #:use-module (guix tests) |
| 24 | #:use-module (json) |
| 25 | #:use-module (ice-9 match) |
| 26 | #:use-module (srfi srfi-1) |
| 27 | #:use-module (srfi srfi-26) |
| 28 | #:use-module (srfi srfi-34) |
| 29 | #:use-module (srfi srfi-64)) |
| 30 | |
| 31 | \f |
| 32 | ;; Some procedures for populating a ‘fake’ ContentDB server. |
| 33 | |
| 34 | (define* (make-package-sexp #:key |
| 35 | (guix-name "minetest-foo") |
| 36 | (home-page "https://example.org/foo") |
| 37 | (repo "https://example.org/foo.git") |
| 38 | (synopsis "synopsis") |
| 39 | (guix-description "description") |
| 40 | (guix-license |
| 41 | '(list license:cc-by-sa4.0 license:lgpl3+)) |
| 42 | (inputs '()) |
| 43 | (upstream-name "Author/foo") |
| 44 | #:allow-other-keys) |
| 45 | `(package |
| 46 | (name ,guix-name) |
| 47 | ;; This is not a proper version number but ContentDB does not include |
| 48 | ;; version numbers. |
| 49 | (version "2021-07-25") |
| 50 | (source |
| 51 | (origin |
| 52 | (method git-fetch) |
| 53 | (uri (git-reference |
| 54 | (url ,(and (not (eq? repo 'null)) repo)) |
| 55 | (commit #f))) |
| 56 | (sha256 |
| 57 | (base32 #f)) |
| 58 | (file-name (git-file-name name version)))) |
| 59 | (build-system minetest-mod-build-system) |
| 60 | ,@(maybe-propagated-inputs inputs) |
| 61 | (home-page ,home-page) |
| 62 | (synopsis ,synopsis) |
| 63 | (description ,guix-description) |
| 64 | (license ,guix-license) |
| 65 | (properties |
| 66 | ,(list 'quasiquote |
| 67 | `((upstream-name . ,upstream-name)))))) |
| 68 | |
| 69 | (define* (make-package-json #:key |
| 70 | (author "Author") |
| 71 | (name "foo") |
| 72 | (media-license "CC-BY-SA-4.0") |
| 73 | (license "LGPL-3.0-or-later") |
| 74 | (short-description "synopsis") |
| 75 | (long-description "description") |
| 76 | (repo "https://example.org/foo.git") |
| 77 | (website "https://example.org/foo") |
| 78 | (forums 321) |
| 79 | (score 987.654) |
| 80 | (downloads 123) |
| 81 | (type "mod") |
| 82 | #:allow-other-keys) |
| 83 | `(("author" . ,author) |
| 84 | ("content_warnings" . #()) |
| 85 | ("created_at" . "2018-05-23T19:58:07.422108") |
| 86 | ("downloads" . ,downloads) |
| 87 | ("forums" . ,forums) |
| 88 | ("issue_tracker" . "https://example.org/foo/issues") |
| 89 | ("license" . ,license) |
| 90 | ("long_description" . ,long-description) |
| 91 | ("maintainers" . #("maintainer")) |
| 92 | ("media_license" . ,media-license) |
| 93 | ("name" . ,name) |
| 94 | ("provides" . #("stuff")) |
| 95 | ("release" . 456) |
| 96 | ("repo" . ,repo) |
| 97 | ("score" . ,score) |
| 98 | ("screenshots" . #()) |
| 99 | ("short_description" . ,short-description) |
| 100 | ("state" . "APPROVED") |
| 101 | ("tags" . #("some" "tags")) |
| 102 | ("thumbnail" . null) |
| 103 | ("title" . "The name") |
| 104 | ("type" . ,type) |
| 105 | ("url" . ,(string-append "https://content.minetest.net/packages/" |
| 106 | author "/" name "/download/")) |
| 107 | ("website" . ,website))) |
| 108 | |
| 109 | (define* (make-releases-json #:key (commit #f) (title "") #:allow-other-keys) |
| 110 | `#((("commit" . ,commit) |
| 111 | ("downloads" . 469) |
| 112 | ("id" . 8614) |
| 113 | ("max_minetest_version" . null) |
| 114 | ("min_minetest_version" . null) |
| 115 | ("release_date" . "2021-07-25T01:10:23.207584") |
| 116 | ("title" . "2021-07-25")))) |
| 117 | |
| 118 | (define* (make-dependencies-json #:key (author "Author") |
| 119 | (name "foo") |
| 120 | (requirements '(("default" #f ()))) |
| 121 | #:allow-other-keys) |
| 122 | `((,(string-append author "/" name) |
| 123 | . ,(list->vector |
| 124 | (map (match-lambda |
| 125 | ((symbolic-name optional? implementations) |
| 126 | `(("is_optional" . ,optional?) |
| 127 | ("name" . ,symbolic-name) |
| 128 | ("packages" . ,(list->vector implementations))))) |
| 129 | requirements))) |
| 130 | ("something/else" . #()))) |
| 131 | |
| 132 | (define* (make-packages-keys-json #:key (author "Author") |
| 133 | (name "Name") |
| 134 | (type "mod")) |
| 135 | `(("author" . ,author) |
| 136 | ("name" . ,name) |
| 137 | ("type" . ,type))) |
| 138 | |
| 139 | (define (call-with-packages thunk . argument-lists) |
| 140 | ;; Don't reuse results from previous tests. |
| 141 | (invalidate-memoization! contentdb-fetch) |
| 142 | (invalidate-memoization! minetest->guix-package) |
| 143 | (define (scm->json-port scm) |
| 144 | (open-input-string (scm->json-string scm))) |
| 145 | (define (handle-package url requested-author requested-name . rest) |
| 146 | (define relevant-argument-list |
| 147 | (any (lambda (argument-list) |
| 148 | (apply (lambda* (#:key (author "Author") (name "foo") |
| 149 | #:allow-other-keys) |
| 150 | (and (equal? requested-author author) |
| 151 | (equal? requested-name name) |
| 152 | argument-list)) |
| 153 | argument-list)) |
| 154 | argument-lists)) |
| 155 | (when (not relevant-argument-list) |
| 156 | (error "the package ~a/~a should be irrelevant, but ~a is fetched" |
| 157 | requested-author requested-name url)) |
| 158 | (scm->json-port |
| 159 | (apply (match rest |
| 160 | (("") make-package-json) |
| 161 | (("dependencies" "") make-dependencies-json) |
| 162 | (("releases" "") make-releases-json) |
| 163 | (_ (error "TODO ~a" rest))) |
| 164 | relevant-argument-list))) |
| 165 | (define (handle-mod-search sort) |
| 166 | ;; Produce search results, sorted by SORT in descending order. |
| 167 | (define arguments->key |
| 168 | (match sort |
| 169 | ("score" (lambda* (#:key (score 987.654) #:allow-other-keys) |
| 170 | score)) |
| 171 | ("downloads" (lambda* (#:key (downloads 123) #:allow-other-keys) |
| 172 | downloads)))) |
| 173 | (define argument-list->key (cut apply arguments->key <>)) |
| 174 | (define (greater x y) |
| 175 | (> (argument-list->key x) (argument-list->key y))) |
| 176 | (define sorted-argument-lists (sort-list argument-lists greater)) |
| 177 | (define* (arguments->json #:key (author "Author") (name "Foo") (type "mod") |
| 178 | #:allow-other-keys) |
| 179 | (and (string=? type "mod") |
| 180 | `(("author" . ,author) |
| 181 | ("name" . ,name) |
| 182 | ("type" . ,type)))) |
| 183 | (define argument-list->json (cut apply arguments->json <>)) |
| 184 | (scm->json-port |
| 185 | (list->vector (filter-map argument-list->json sorted-argument-lists)))) |
| 186 | (mock ((guix http-client) http-fetch |
| 187 | (lambda* (url #:key headers) |
| 188 | (unless (string-prefix? "mock://api/packages/" url) |
| 189 | (error "the URL ~a should not be used" url)) |
| 190 | (define resource |
| 191 | (substring url (string-length "mock://api/packages/"))) |
| 192 | (define components (string-split resource #\/)) |
| 193 | (match components |
| 194 | ((author name . rest) |
| 195 | (apply handle-package url author name rest)) |
| 196 | (((? (cut string-prefix? "?type=mod&q=" <>) query)) |
| 197 | (handle-mod-search |
| 198 | (cond ((string-contains query "sort=score") "score") |
| 199 | ((string-contains query "sort=downloads") "downloads") |
| 200 | (#t (error "search query ~a has unknown sort key" |
| 201 | query))))) |
| 202 | (_ |
| 203 | (error "the URL ~a should have an author and name component" |
| 204 | url))))) |
| 205 | (parameterize ((%contentdb-api "mock://api/")) |
| 206 | (thunk)))) |
| 207 | |
| 208 | (define* (minetest->guix-package* #:key (author "Author") (name "foo") |
| 209 | (sort %default-sort-key) |
| 210 | #:allow-other-keys) |
| 211 | (minetest->guix-package (string-append author "/" name) #:sort sort)) |
| 212 | |
| 213 | (define (imported-package-sexp* primary-arguments . secondary-arguments) |
| 214 | "Ask the importer to import a package specified by PRIMARY-ARGUMENTS, |
| 215 | during a dynamic where that package and the packages specified by |
| 216 | SECONDARY-ARGUMENTS are available on ContentDB." |
| 217 | (apply call-with-packages |
| 218 | (lambda () |
| 219 | ;; The memoization cache is reset by call-with-packages |
| 220 | (apply minetest->guix-package* primary-arguments)) |
| 221 | primary-arguments |
| 222 | secondary-arguments)) |
| 223 | |
| 224 | (define (imported-package-sexp . extra-arguments) |
| 225 | "Ask the importer to import a package specified by EXTRA-ARGUMENTS, |
| 226 | during a dynamic extent where that package is available on ContentDB." |
| 227 | (imported-package-sexp* extra-arguments)) |
| 228 | |
| 229 | (define-syntax-rule (test-package test-case . extra-arguments) |
| 230 | (test-equal test-case |
| 231 | (make-package-sexp . extra-arguments) |
| 232 | (imported-package-sexp . extra-arguments))) |
| 233 | |
| 234 | (define-syntax-rule (test-package* test-case primary-arguments extra-arguments |
| 235 | ...) |
| 236 | (test-equal test-case |
| 237 | (apply make-package-sexp primary-arguments) |
| 238 | (imported-package-sexp* primary-arguments extra-arguments ...))) |
| 239 | |
| 240 | (test-begin "minetest") |
| 241 | |
| 242 | \f |
| 243 | ;; Package names |
| 244 | (test-package "minetest->guix-package") |
| 245 | (test-package "minetest->guix-package, _ → - in package name" |
| 246 | #:name "foo_bar" |
| 247 | #:guix-name "minetest-foo-bar" |
| 248 | #:upstream-name "Author/foo_bar") |
| 249 | |
| 250 | (test-equal "elaborate names, unambigious" |
| 251 | "Jeija/mesecons" |
| 252 | (call-with-packages |
| 253 | (cut elaborate-contentdb-name "mesecons") |
| 254 | '(#:name "mesecons" #:author "Jeija") |
| 255 | '(#:name "something" #:author "else"))) |
| 256 | |
| 257 | (test-equal "elaborate name, ambigious (highest score)" |
| 258 | "Jeija/mesecons" |
| 259 | (call-with-packages |
| 260 | ;; #:sort "score" is the default |
| 261 | (cut elaborate-contentdb-name "mesecons") |
| 262 | '(#:name "mesecons" #:author "Jeijc" #:score 777) |
| 263 | '(#:name "mesecons" #:author "Jeijb" #:score 888) |
| 264 | '(#:name "mesecons" #:author "Jeija" #:score 999))) |
| 265 | |
| 266 | |
| 267 | (test-equal "elaborate name, ambigious (most downloads)" |
| 268 | "Jeija/mesecons" |
| 269 | (call-with-packages |
| 270 | (cut elaborate-contentdb-name "mesecons" #:sort "downloads") |
| 271 | '(#:name "mesecons" #:author "Jeijc" #:downloads 777) |
| 272 | '(#:name "mesecons" #:author "Jeijb" #:downloads 888) |
| 273 | '(#:name "mesecons" #:author "Jeija" #:downloads 999))) |
| 274 | |
| 275 | \f |
| 276 | ;; Determining the home page |
| 277 | (test-package "minetest->guix-package, website is used as home page" |
| 278 | #:home-page "web://site" |
| 279 | #:website "web://site") |
| 280 | (test-package "minetest->guix-package, if absent, the forum is used" |
| 281 | #:home-page '(minetest-topic 628) |
| 282 | #:forums 628 |
| 283 | #:website 'null) |
| 284 | (test-package "minetest->guix-package, if absent, the git repo is used" |
| 285 | #:home-page "https://github.com/minetest-mods/mesecons" |
| 286 | #:forums 'null |
| 287 | #:website 'null |
| 288 | #:repo "https://github.com/minetest-mods/mesecons") |
| 289 | (test-package "minetest->guix-package, all home page information absent" |
| 290 | #:home-page #f |
| 291 | #:forums 'null |
| 292 | #:website 'null |
| 293 | #:repo 'null) |
| 294 | |
| 295 | \f |
| 296 | |
| 297 | ;; Dependencies |
| 298 | (test-package* "minetest->guix-package, unambigious dependency" |
| 299 | (list #:requirements '(("mesecons" #f |
| 300 | ("Jeija/mesecons" |
| 301 | "some-modpack/containing-mese"))) |
| 302 | #:inputs '("minetest-mesecons")) |
| 303 | (list #:author "Jeija" #:name "mesecons") |
| 304 | (list #:author "some-modpack" #:name "containing-mese" #:type "modpack")) |
| 305 | |
| 306 | (test-package* "minetest->guix-package, ambigious dependency (highest score)" |
| 307 | (list #:name "frobnicate" |
| 308 | #:guix-name "minetest-frobnicate" |
| 309 | #:upstream-name "Author/frobnicate" |
| 310 | #:requirements '(("frob" #f |
| 311 | ("Author/foo" "Author/bar"))) |
| 312 | ;; #:sort "score" is the default |
| 313 | #:inputs '("minetest-bar")) |
| 314 | (list #:author "Author" #:name "foo" #:score 0) |
| 315 | (list #:author "Author" #:name "bar" #:score 9999)) |
| 316 | |
| 317 | (test-package* "minetest->guix-package, ambigious dependency (most downloads)" |
| 318 | (list #:name "frobnicate" |
| 319 | #:guix-name "minetest-frobnicate" |
| 320 | #:upstream-name "Author/frobnicate" |
| 321 | #:requirements '(("frob" #f |
| 322 | ("Author/foo" "Author/bar"))) |
| 323 | #:inputs '("minetest-bar") |
| 324 | #:sort "downloads") |
| 325 | (list #:author "Author" #:name "foo" #:downloads 0) |
| 326 | (list #:author "Author" #:name "bar" #:downloads 9999)) |
| 327 | |
| 328 | (test-package "minetest->guix-package, optional dependency" |
| 329 | #:requirements '(("mesecons" #t |
| 330 | ("Jeija/mesecons" |
| 331 | "some-modpack/containing-mese"))) |
| 332 | #:inputs '()) |
| 333 | |
| 334 | \f |
| 335 | ;; License |
| 336 | (test-package "minetest->guix-package, identical licenses" |
| 337 | #:guix-license 'license:lgpl3+ |
| 338 | #:license "LGPL-3.0-or-later" |
| 339 | #:media-license "LGPL-3.0-or-later") |
| 340 | |
| 341 | ;; Sorting |
| 342 | (let* ((make-package |
| 343 | (lambda arguments |
| 344 | (json->package (apply make-package-json arguments)))) |
| 345 | (x (make-package #:score 0)) |
| 346 | (y (make-package #:score 1)) |
| 347 | (z (make-package #:score 2))) |
| 348 | (test-equal "sort-packages, already sorted" |
| 349 | (list z y x) |
| 350 | (sort-packages (list z y x))) |
| 351 | (test-equal "sort-packages, reverse" |
| 352 | (list z y x) |
| 353 | (sort-packages (list x y z)))) |
| 354 | |
| 355 | (test-end "minetest") |