[jackhill/guix/guix.git] / tests / minetest.scm

;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2021 Maxime Devos <maximedevos@telenet.be>
;;;
;;; 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 (test-minetest)
  #:use-module (guix build-system minetest)
  #:use-module (guix upstream)
  #:use-module (guix memoization)
  #:use-module (guix import minetest)
  #:use-module (guix import utils)
  #:use-module (guix tests)
  #:use-module (guix packages)
  #:use-module (guix git-download)
  #:use-module ((gnu packages minetest)
                #:select (minetest minetest-technic))
  #:use-module ((gnu packages base)
                #:select (hello))
  #:use-module (json)
  #:use-module (ice-9 match)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-26)
  #:use-module (srfi srfi-34)
  #:use-module (srfi srfi-64))

\f
;; Some procedures for populating a ‘fake’ ContentDB server.

(define* (make-package-sexp #:key
                            (guix-name "minetest-foo")
                            ;; This is not a proper version number but
                            ;; ContentDB often does not include version
                            ;; numbers.
                            (version "2021-07-25")
                            (home-page "https://example.org/foo")
                            (repo "https://example.org/foo.git")
                            (synopsis "synopsis")
                            (guix-description "description")
                            (guix-license
                             '(list license:cc-by-sa4.0 license:lgpl3+))
                            (inputs '())
                            (upstream-name "Author/foo")
                            #:allow-other-keys)
  `(package
     (name ,guix-name)
     (version ,version)
     (source
      (origin
        (method git-fetch)
        (uri (git-reference
              (url ,(and (not (eq? repo 'null)) repo))
              (commit #f)))
        (sha256
         (base32 #f))
        (file-name (git-file-name name version))))
     (build-system minetest-mod-build-system)
     ,@(maybe-propagated-inputs inputs)
     (home-page ,home-page)
     (synopsis ,synopsis)
     (description ,guix-description)
     (license ,guix-license)
     (properties
      ,(list 'quasiquote
             `((upstream-name . ,upstream-name))))))

(define* (make-package-json #:key
                            (author "Author")
                            (name "foo")
                            (media-license "CC-BY-SA-4.0")
                            (license "LGPL-3.0-or-later")
                            (short-description "synopsis")
                            (long-description "description")
                            (repo "https://example.org/foo.git")
                            (website "https://example.org/foo")
                            (forums 321)
                            (score 987.654)
                            (downloads 123)
                            (type "mod")
                            #:allow-other-keys)
  `(("author" . ,author)
    ("content_warnings" . #())
    ("created_at" . "2018-05-23T19:58:07.422108")
    ("downloads" . ,downloads)
    ("forums" . ,forums)
    ("issue_tracker" . "https://example.org/foo/issues")
    ("license" . ,license)
    ("long_description" . ,long-description)
    ("maintainers" . #("maintainer"))
    ("media_license" . ,media-license)
    ("name" . ,name)
    ("provides" . #("stuff"))
    ("release" . 456)
    ("repo" . ,repo)
    ("score" . ,score)
    ("screenshots" . #())
    ("short_description" . ,short-description)
    ("state" . "APPROVED")
    ("tags" . #("some" "tags"))
    ("thumbnail" . null)
    ("title" . "The name")
    ("type" . ,type)
    ("url" . ,(string-append "https://content.minetest.net/packages/"
                             author "/" name "/download/"))
    ("website" . ,website)))

(define* (make-releases-json #:key (commit #f) (title "2021-07-25") #:allow-other-keys)
  `#((("commit" . ,commit)
      ("downloads" . 469)
      ("id" . 8614)
      ("max_minetest_version" . null)
      ("min_minetest_version" . null)
      ("release_date" . "2021-07-25T01:10:23.207584")
      ("title" . ,title))))

(define* (make-dependencies-json #:key (author "Author")
                                 (name "foo")
                                 (requirements '(("default" #f ())))
                                 #:allow-other-keys)
  `((,(string-append author "/" name)
     . ,(list->vector
         (map (match-lambda
                ((symbolic-name optional? implementations)
                 `(("is_optional" . ,optional?)
                   ("name" . ,symbolic-name)
                   ("packages" . ,(list->vector implementations)))))
              requirements)))
    ("something/else" . #())))

(define* (make-packages-keys-json #:key (author "Author")
                                  (name "Name")
                                  (type "mod"))
  `(("author" . ,author)
    ("name" . ,name)
    ("type" . ,type)))

(define (call-with-packages thunk . argument-lists)
  ;; Don't reuse results from previous tests.
  (invalidate-memoization! contentdb-fetch)
  (invalidate-memoization! minetest->guix-package)
  (define (scm->json-port scm)
    (open-input-string (scm->json-string scm)))
  (define (handle-package url requested-author requested-name . rest)
    (define relevant-argument-list
      (any (lambda (argument-list)
             (apply (lambda* (#:key (author "Author") (name "foo")
                              #:allow-other-keys)
                      (and (equal? requested-author author)
                           (equal? requested-name name)
                           argument-list))
                    argument-list))
           argument-lists))
    (when (not relevant-argument-list)
      (error "the package ~a/~a should be irrelevant, but ~a is fetched"
             requested-author requested-name url))
    (scm->json-port
     (apply (match rest
              (("") make-package-json)
              (("dependencies" "") make-dependencies-json)
              (("releases" "") make-releases-json)
              (_ (error "TODO ~a" rest)))
            relevant-argument-list)))
  (define (handle-mod-search sort)
    ;; Produce search results, sorted by SORT in descending order.
    (define arguments->key
      (match sort
        ("score" (lambda* (#:key (score 987.654) #:allow-other-keys)
                   score))
        ("downloads" (lambda* (#:key (downloads 123) #:allow-other-keys)
                       downloads))))
    (define argument-list->key (cut apply arguments->key <>))
    (define (greater x y)
      (> (argument-list->key x) (argument-list->key y)))
    (define sorted-argument-lists (sort-list argument-lists greater))
    (define* (arguments->json #:key (author "Author") (name "Foo") (type "mod")
                              #:allow-other-keys)
      (and (string=? type "mod")
           `(("author" . ,author)
             ("name" . ,name)
             ("type" . ,type))))
    (define argument-list->json (cut apply arguments->json <>))
    (scm->json-port
     (list->vector (filter-map argument-list->json sorted-argument-lists))))
  (mock ((guix http-client) http-fetch
         (lambda* (url #:key headers)
           (unless (string-prefix? "mock://api/packages/" url)
             (error "the URL ~a should not be used" url))
           (define resource
             (substring url (string-length "mock://api/packages/")))
           (define components (string-split resource #\/))
           (match components
             ((author name . rest)
              (apply handle-package url author name rest))
             (((? (cut string-prefix? "?type=mod&q=" <>) query))
              (handle-mod-search
               (cond ((string-contains query "sort=score") "score")
                     ((string-contains query "sort=downloads") "downloads")
                     (#t (error "search query ~a has unknown sort key"
                                query)))))
             (_
              (error "the URL ~a should have an author and name component"
                     url)))))
        (parameterize ((%contentdb-api "mock://api/"))
          (thunk))))

(define* (minetest->guix-package* #:key (author "Author") (name "foo")
                                  (sort %default-sort-key)
                                  #:allow-other-keys)
  (minetest->guix-package (string-append author "/" name) #:sort sort))

(define (imported-package-sexp* primary-arguments . secondary-arguments)
  "Ask the importer to import a package specified by PRIMARY-ARGUMENTS,
during a dynamic where that package and the packages specified by
SECONDARY-ARGUMENTS are available on ContentDB."
  (apply call-with-packages
         (lambda ()
           ;; The memoization cache is reset by call-with-packages
           (apply minetest->guix-package* primary-arguments))
   primary-arguments
   secondary-arguments))

(define (imported-package-sexp . extra-arguments)
  "Ask the importer to import a package specified by EXTRA-ARGUMENTS,
during a dynamic extent where that package is available on ContentDB."
  (imported-package-sexp* extra-arguments))

(define-syntax-rule (test-package test-case . extra-arguments)
  (test-equal test-case
    (make-package-sexp . extra-arguments)
    (imported-package-sexp . extra-arguments)))

(define-syntax-rule (test-package* test-case primary-arguments extra-arguments
                                   ...)
  (test-equal test-case
    (apply make-package-sexp primary-arguments)
    (imported-package-sexp* primary-arguments extra-arguments ...)))

(test-begin "minetest")

\f
;; Package names
(test-package "minetest->guix-package")
(test-package "minetest->guix-package, _ → - in package name"
              #:name "foo_bar"
              #:guix-name "minetest-foo-bar"
              #:upstream-name "Author/foo_bar")

(test-equal "elaborate names, unambiguous"
  "Jeija/mesecons"
  (call-with-packages
   (cut elaborate-contentdb-name "mesecons")
   '(#:name "mesecons" #:author "Jeija")
   '(#:name "something" #:author "else")))

(test-equal "elaborate name, ambiguous (highest score)"
  "Jeija/mesecons"
  (call-with-packages
   ;; #:sort "score" is the default
   (cut elaborate-contentdb-name "mesecons")
   '(#:name "mesecons" #:author "Jeijc" #:score 777)
   '(#:name "mesecons" #:author "Jeijb" #:score 888)
   '(#:name "mesecons" #:author "Jeija" #:score 999)))


(test-equal "elaborate name, ambiguous (most downloads)"
  "Jeija/mesecons"
  (call-with-packages
   (cut elaborate-contentdb-name "mesecons" #:sort "downloads")
   '(#:name "mesecons" #:author "Jeijc" #:downloads 777)
   '(#:name "mesecons" #:author "Jeijb" #:downloads 888)
   '(#:name "mesecons" #:author "Jeija" #:downloads 999)))

\f
;; Determining the home page
(test-package "minetest->guix-package, website is used as home page"
              #:home-page "web://site"
              #:website "web://site")
(test-package "minetest->guix-package, if absent, the forum is used"
              #:home-page '(minetest-topic 628)
              #:forums 628
              #:website 'null)
(test-package "minetest->guix-package, if absent, the git repo is used"
              #:home-page "https://github.com/minetest-mods/mesecons"
              #:forums 'null
              #:website 'null
              #:repo "https://github.com/minetest-mods/mesecons")
(test-package "minetest->guix-package, all home page information absent"
              #:home-page #f
              #:forums 'null
              #:website 'null
              #:repo 'null)

\f
;; Determining the version number

(test-package "conventional version number" #:version "1.2.3" #:title "1.2.3")
;; See e.g. orwell/basic_trains
(test-package "v-prefixed version number" #:version "1.2.3" #:title "v1.2.3")
;; Many mods on ContentDB use dates as release titles.  In that case, the date
;; will have to do.
(test-package "dates as version number"
              #:version "2021-01-01" #:title "2021-01-01")

\f

;; Dependencies
(test-package* "minetest->guix-package, unambiguous dependency"
  (list #:requirements '(("mesecons" #f
                          ("Jeija/mesecons"
                           "some-modpack/containing-mese")))
        #:inputs '("minetest-mesecons"))
  (list #:author "Jeija" #:name "mesecons")
  (list #:author "some-modpack" #:name "containing-mese" #:type "modpack"))

(test-package* "minetest->guix-package, ambiguous dependency (highest score)"
  (list #:name "frobnicate"
        #:guix-name "minetest-frobnicate"
        #:upstream-name "Author/frobnicate"
        #:requirements '(("frob" #f
                          ("Author/foo" "Author/bar")))
        ;; #:sort "score" is the default
        #:inputs '("minetest-bar"))
  (list #:author "Author" #:name "foo" #:score 0)
  (list #:author "Author" #:name "bar" #:score 9999))

(test-package* "minetest->guix-package, ambiguous dependency (most downloads)"
  (list #:name "frobnicate"
        #:guix-name "minetest-frobnicate"
        #:upstream-name "Author/frobnicate"
        #:requirements '(("frob" #f
                          ("Author/foo" "Author/bar")))
        #:inputs '("minetest-bar")
        #:sort "downloads")
  (list #:author "Author" #:name "foo" #:downloads 0)
  (list #:author "Author" #:name "bar" #:downloads 9999))

(test-package "minetest->guix-package, optional dependency"
              #:requirements '(("mesecons" #t
                                ("Jeija/mesecons"
                                 "some-modpack/containing-mese")))
              #:inputs '())

;; See e.g. 'orwell/basic_trains'
(test-package* "minetest->guix-package, multiple dependencies implemented by one mod"
  (list #:name "frobnicate"
        #:guix-name "minetest-frobnicate"
        #:upstream-name "Author/frobnicate"
        #:requirements '(("frob" #f ("Author/frob"))
                         ("frob_x" #f ("Author/frob")))
        #:inputs '("minetest-frob"))
  (list #:author "Author" #:name "frob"))

\f
;; License
(test-package "minetest->guix-package, identical licenses"
              #:guix-license 'license:lgpl3+
              #:license "LGPL-3.0-or-later"
              #:media-license "LGPL-3.0-or-later")

;; Sorting
(let* ((make-package
        (lambda arguments
          (json->package (apply make-package-json arguments))))
       (x (make-package #:score 0))
       (y (make-package #:score 1))
       (z (make-package #:score 2)))
  (test-equal "sort-packages, already sorted"
    (list z y x)
    (sort-packages (list z y x)))
  (test-equal "sort-packages, reverse"
    (list z y x)
    (sort-packages (list x y z))))

\f

;; Update detection
(define (upstream-source->sexp upstream-source)
  (define url (upstream-source-urls upstream-source))
  (unless (git-reference? url)
    (error "a <git-reference> is expected"))
  `(,(upstream-source-package upstream-source)
    ,(upstream-source-version upstream-source)
    ,(git-reference-url url)
    ,(git-reference-commit url)))

(define* (expected-sexp #:key
                        (repo "https://example.org/foo.git")
                        (guix-name "minetest-foo")
                        (new-version "0.8")
                        (commit "44941798d222901b8f381b3210957d880b90a2fc")
                        #:allow-other-keys)
  `(,guix-name ,new-version ,repo ,commit))

(define* (example-package #:key
                          (source 'auto)
                          (repo "https://example.org/foo.git")
                          (old-version "0.8")
                          (commit "44941798d222901b8f381b3210957d880b90a2fc")
                          #:allow-other-keys)
  (package
    (name "minetest-foo")
    (version old-version)
    (source
     (if (eq? source 'auto)
         (origin
           (method git-fetch)
           (uri (git-reference
                 (url repo)
                 (commit commit #;"808f9ffbd3106da4c92d2367b118b98196c9e81e")))
           (sha256 #f) ; not important for the following tests
           (file-name (git-file-name name version)))
         source))
    (build-system minetest-mod-build-system)
    (license #f)
    (synopsis #f)
    (description #f)
    (home-page #f)
    (properties '((upstream-name . "Author/foo")))))

(define-syntax-rule (test-release test-case . arguments)
  (test-equal test-case
    (expected-sexp . arguments)
    (and=>
     (call-with-packages
      (cut latest-minetest-release (example-package . arguments))
      (list . arguments))
     upstream-source->sexp)))

(define-syntax-rule (test-no-release test-case . arguments)
  (test-equal test-case
    #f
    (call-with-packages
     (cut latest-minetest-release (example-package . arguments))
     (list . arguments))))

(test-release "same version"
  #:old-version "0.8" #:title "0.8" #:new-version "0.8"
  #:commit "44941798d222901b8f381b3210957d880b90a2fc")

(test-release "new version (dotted)"
  #:old-version "0.8" #:title "0.9.0" #:new-version "0.9.0"
  #:commit "c8855b991880897b2658dc90164e29c96e2aeb3a")

(test-release "new version (date)"
  #:old-version "2014-11-17" #:title "2015-11-04"
  #:new-version "2015-11-04"
  #:commit "c8855b991880897b2658dc90164e29c96e2aeb3a")

(test-release "new version (git -> dotted)"
  #:old-version
  (git-version "0.8" "1" "90422555f114d3af35e7cc4b5b6d59a5c226adc4")
  #:title "0.9.0" #:new-version "0.9.0"
  #:commit "90422555f114d3af35e7cc4b5b6d59a5c226adc4")

;; There might actually be a new release, but guix cannot compare dates
;; with regular version numbers.
(test-no-release "dotted -> date"
  #:old-version "0.8" #:title "2015-11-04"
  #:commit "c8855b991880897b2658dc90164e29c96e2aeb3a")

(test-no-release "date -> dotted"
  #:old-version "2014-11-07" #:title "0.8"
  #:commit "c8855b991880897b2658dc90164e29c96e2aeb3a")

;; Don't let "guix refresh -t minetest" tell there are new versions
;; if Guix has insufficient information to actually perform the update,
;; when using --with-latest or "guix refresh -u".
(test-no-release "no commit information, no new release"
  #:old-version "0.8" #:title "0.9.0" #:new-version "0.9.0"
  #:commit #false)

(test-assert "minetest is not a minetest mod"
  (not (minetest-package? minetest)))
(test-assert "GNU hello is not a minetest mod"
  (not (minetest-package? hello)))
(test-assert "technic is a minetest mod"
  (minetest-package? minetest-technic))
(test-assert "upstream-name is required"
  (not (minetest-package?
        (package (inherit minetest-technic)
                 (properties '())))))

(test-end "minetest")

;;; Local Variables:
;;; eval: (put 'test-package* 'scheme-indent-function 1)
;;; eval: (put 'test-release 'scheme-indent-function 1)
;;; eval: (put 'test-no-release 'scheme-indent-function 1)
;;; End:
Commit	Line	Data
467e874a MD	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)
085a8a0c MD	20	#:use-module (guix build-system minetest)
085a8a0c MD	21	#:use-module (guix upstream)
467e874a MD	22	#:use-module (guix memoization)
	23	#:use-module (guix import minetest)
	24	#:use-module (guix import utils)
	25	#:use-module (guix tests)
085a8a0c MD	26	#:use-module (guix packages)
	27	#:use-module (guix git-download)
	28	#:use-module ((gnu packages minetest)
	29	#:select (minetest minetest-technic))
	30	#:use-module ((gnu packages base)
	31	#:select (hello))
467e874a MD	32	#:use-module (json)
	33	#:use-module (ice-9 match)
	34	#:use-module (srfi srfi-1)
	35	#:use-module (srfi srfi-26)
	36	#:use-module (srfi srfi-34)
	37	#:use-module (srfi srfi-64))
	38
	39	\f
	40	;; Some procedures for populating a ‘fake’ ContentDB server.
	41
	42	(define* (make-package-sexp #:key
	43	(guix-name "minetest-foo")
808f9ffb MD	44	;; This is not a proper version number but
	45	;; ContentDB often does not include version
	46	;; numbers.
	47	(version "2021-07-25")
467e874a MD	48	(home-page "https://example.org/foo")
	49	(repo "https://example.org/foo.git")
	50	(synopsis "synopsis")
	51	(guix-description "description")
	52	(guix-license
	53	'(list license:cc-by-sa4.0 license:lgpl3+))
	54	(inputs '())
	55	(upstream-name "Author/foo")
	56	#:allow-other-keys)
	57	`(package
	58	(name ,guix-name)
808f9ffb	59	(version ,version)
467e874a MD	60	(source
	61	(origin
	62	(method git-fetch)
	63	(uri (git-reference
	64	(url ,(and (not (eq? repo 'null)) repo))
	65	(commit #f)))
	66	(sha256
	67	(base32 #f))
	68	(file-name (git-file-name name version))))
	69	(build-system minetest-mod-build-system)
	70	,@(maybe-propagated-inputs inputs)
	71	(home-page ,home-page)
	72	(synopsis ,synopsis)
	73	(description ,guix-description)
	74	(license ,guix-license)
	75	(properties
	76	,(list 'quasiquote
	77	`((upstream-name . ,upstream-name))))))
	78
	79	(define* (make-package-json #:key
	80	(author "Author")
	81	(name "foo")
	82	(media-license "CC-BY-SA-4.0")
	83	(license "LGPL-3.0-or-later")
	84	(short-description "synopsis")
	85	(long-description "description")
	86	(repo "https://example.org/foo.git")
	87	(website "https://example.org/foo")
	88	(forums 321)
	89	(score 987.654)
	90	(downloads 123)
	91	(type "mod")
	92	#:allow-other-keys)
	93	`(("author" . ,author)
	94	("content_warnings" . #())
	95	("created_at" . "2018-05-23T19:58:07.422108")
	96	("downloads" . ,downloads)
	97	("forums" . ,forums)
	98	("issue_tracker" . "https://example.org/foo/issues")
	99	("license" . ,license)
	100	("long_description" . ,long-description)
	101	("maintainers" . #("maintainer"))
	102	("media_license" . ,media-license)
	103	("name" . ,name)
	104	("provides" . #("stuff"))
	105	("release" . 456)
	106	("repo" . ,repo)
	107	("score" . ,score)
	108	("screenshots" . #())
	109	("short_description" . ,short-description)
	110	("state" . "APPROVED")
	111	("tags" . #("some" "tags"))
	112	("thumbnail" . null)
	113	("title" . "The name")
	114	("type" . ,type)
	115	("url" . ,(string-append "https://content.minetest.net/packages/"
	116	author "/" name "/download/"))
	117	("website" . ,website)))
	118
808f9ffb	119	(define* (make-releases-json #:key (commit #f) (title "2021-07-25") #:allow-other-keys)
467e874a MD	120	`#((("commit" . ,commit)
	121	("downloads" . 469)
	122	("id" . 8614)
	123	("max_minetest_version" . null)
	124	("min_minetest_version" . null)
	125	("release_date" . "2021-07-25T01:10:23.207584")
808f9ffb	126	("title" . ,title))))
467e874a MD	127
	128	(define* (make-dependencies-json #:key (author "Author")
	129	(name "foo")
	130	(requirements '(("default" #f ())))
	131	#:allow-other-keys)
	132	`((,(string-append author "/" name)
	133	. ,(list->vector
	134	(map (match-lambda
	135	((symbolic-name optional? implementations)
	136	`(("is_optional" . ,optional?)
	137	("name" . ,symbolic-name)
	138	("packages" . ,(list->vector implementations)))))
	139	requirements)))
	140	("something/else" . #())))
	141
	142	(define* (make-packages-keys-json #:key (author "Author")
	143	(name "Name")
	144	(type "mod"))
	145	`(("author" . ,author)
	146	("name" . ,name)
	147	("type" . ,type)))
	148
	149	(define (call-with-packages thunk . argument-lists)
	150	;; Don't reuse results from previous tests.
	151	(invalidate-memoization! contentdb-fetch)
	152	(invalidate-memoization! minetest->guix-package)
	153	(define (scm->json-port scm)
	154	(open-input-string (scm->json-string scm)))
	155	(define (handle-package url requested-author requested-name . rest)
	156	(define relevant-argument-list
	157	(any (lambda (argument-list)
	158	(apply (lambda* (#:key (author "Author") (name "foo")
	159	#:allow-other-keys)
	160	(and (equal? requested-author author)
	161	(equal? requested-name name)
	162	argument-list))
	163	argument-list))
	164	argument-lists))
	165	(when (not relevant-argument-list)
	166	(error "the package ~a/~a should be irrelevant, but ~a is fetched"
	167	requested-author requested-name url))
	168	(scm->json-port
	169	(apply (match rest
	170	(("") make-package-json)
	171	(("dependencies" "") make-dependencies-json)
	172	(("releases" "") make-releases-json)
	173	(_ (error "TODO ~a" rest)))
	174	relevant-argument-list)))
	175	(define (handle-mod-search sort)
	176	;; Produce search results, sorted by SORT in descending order.
	177	(define arguments->key
	178	(match sort
	179	("score" (lambda* (#:key (score 987.654) #:allow-other-keys)
	180	score))
	181	("downloads" (lambda* (#:key (downloads 123) #:allow-other-keys)
	182	downloads))))
	183	(define argument-list->key (cut apply arguments->key <>))
	184	(define (greater x y)
	185	(> (argument-list->key x) (argument-list->key y)))
	186	(define sorted-argument-lists (sort-list argument-lists greater))
	187	(define* (arguments->json #:key (author "Author") (name "Foo") (type "mod")
	188	#:allow-other-keys)
	189	(and (string=? type "mod")
	190	`(("author" . ,author)
191	("name" . ,name)
192	("type" . ,type))))
193	(define argument-list->json (cut apply arguments->json <>))
194	(scm->json-port
195	(list->vector (filter-map argument-list->json sorted-argument-lists))))
196	(mock ((guix http-client) http-fetch
197	(lambda* (url #:key headers)
198	(unless (string-prefix? "mock://api/packages/" url)
199	(error "the URL ~a should not be used" url))
200	(define resource
201	(substring url (string-length "mock://api/packages/")))
202	(define components (string-split resource #\/))
203	(match components
204	((author name . rest)
205	(apply handle-package url author name rest))
206	(((? (cut string-prefix? "?type=mod&q=" <>) query))
207	(handle-mod-search
208	(cond ((string-contains query "sort=score") "score")
209	((string-contains query "sort=downloads") "downloads")
210	(#t (error "search query ~a has unknown sort key"
211	query)))))
212	(_
213	(error "the URL ~a should have an author and name component"
214	url)))))
215	(parameterize ((%contentdb-api "mock://api/"))
216	(thunk))))
217
218	(define* (minetest->guix-package* #:key (author "Author") (name "foo")
219	(sort %default-sort-key)
220	#:allow-other-keys)
221	(minetest->guix-package (string-append author "/" name) #:sort sort))
222
223	(define (imported-package-sexp* primary-arguments . secondary-arguments)
224	"Ask the importer to import a package specified by PRIMARY-ARGUMENTS,
225	during a dynamic where that package and the packages specified by
226	SECONDARY-ARGUMENTS are available on ContentDB."
227	(apply call-with-packages
228	(lambda ()
229	;; The memoization cache is reset by call-with-packages
230	(apply minetest->guix-package* primary-arguments))
231	primary-arguments
232	secondary-arguments))
233
234	(define (imported-package-sexp . extra-arguments)
235	"Ask the importer to import a package specified by EXTRA-ARGUMENTS,
236	during a dynamic extent where that package is available on ContentDB."
237	(imported-package-sexp* extra-arguments))
238
239	(define-syntax-rule (test-package test-case . extra-arguments)
240	(test-equal test-case
241	(make-package-sexp . extra-arguments)
242	(imported-package-sexp . extra-arguments)))
243
244	(define-syntax-rule (test-package* test-case primary-arguments extra-arguments
245	...)
246	(test-equal test-case
247	(apply make-package-sexp primary-arguments)
248	(imported-package-sexp* primary-arguments extra-arguments ...)))
249
250	(test-begin "minetest")
251
252	\f
253	;; Package names
254	(test-package "minetest->guix-package")
255	(test-package "minetest->guix-package, _ → - in package name"
256	#:name "foo_bar"
257	#:guix-name "minetest-foo-bar"
258	#:upstream-name "Author/foo_bar")
259
2f5368d6	260	(test-equal "elaborate names, unambiguous"
467e874a MD	261	"Jeija/mesecons"
	262	(call-with-packages
	263	(cut elaborate-contentdb-name "mesecons")
	264	'(#:name "mesecons" #:author "Jeija")
	265	'(#:name "something" #:author "else")))
	266
2f5368d6	267	(test-equal "elaborate name, ambiguous (highest score)"
467e874a MD	268	"Jeija/mesecons"
	269	(call-with-packages
	270	;; #:sort "score" is the default
	271	(cut elaborate-contentdb-name "mesecons")
	272	'(#:name "mesecons" #:author "Jeijc" #:score 777)
	273	'(#:name "mesecons" #:author "Jeijb" #:score 888)
	274	'(#:name "mesecons" #:author "Jeija" #:score 999)))
	275
	276
2f5368d6	277	(test-equal "elaborate name, ambiguous (most downloads)"
467e874a MD	278	"Jeija/mesecons"
	279	(call-with-packages
	280	(cut elaborate-contentdb-name "mesecons" #:sort "downloads")
	281	'(#:name "mesecons" #:author "Jeijc" #:downloads 777)
	282	'(#:name "mesecons" #:author "Jeijb" #:downloads 888)
	283	'(#:name "mesecons" #:author "Jeija" #:downloads 999)))
	284
	285	\f
	286	;; Determining the home page
	287	(test-package "minetest->guix-package, website is used as home page"
	288	#:home-page "web://site"
	289	#:website "web://site")
	290	(test-package "minetest->guix-package, if absent, the forum is used"
	291	#:home-page '(minetest-topic 628)
	292	#:forums 628
	293	#:website 'null)
	294	(test-package "minetest->guix-package, if absent, the git repo is used"
	295	#:home-page "https://github.com/minetest-mods/mesecons"
	296	#:forums 'null
	297	#:website 'null
	298	#:repo "https://github.com/minetest-mods/mesecons")
	299	(test-package "minetest->guix-package, all home page information absent"
	300	#:home-page #f
	301	#:forums 'null
	302	#:website 'null
	303	#:repo 'null)
	304
	305	\f
808f9ffb MD	306	;; Determining the version number
	307
	308	(test-package "conventional version number" #:version "1.2.3" #:title "1.2.3")
	309	;; See e.g. orwell/basic_trains
	310	(test-package "v-prefixed version number" #:version "1.2.3" #:title "v1.2.3")
	311	;; Many mods on ContentDB use dates as release titles. In that case, the date
	312	;; will have to do.
	313	(test-package "dates as version number"
	314	#:version "2021-01-01" #:title "2021-01-01")
	315
	316	\f
467e874a MD	317
467e874a MD	318	;; Dependencies
2f5368d6	319	(test-package* "minetest->guix-package, unambiguous dependency"
467e874a MD	320	(list #:requirements '(("mesecons" #f
	321	("Jeija/mesecons"
	322	"some-modpack/containing-mese")))
	323	#:inputs '("minetest-mesecons"))
	324	(list #:author "Jeija" #:name "mesecons")
	325	(list #:author "some-modpack" #:name "containing-mese" #:type "modpack"))
	326
2f5368d6	327	(test-package* "minetest->guix-package, ambiguous dependency (highest score)"
467e874a MD	328	(list #:name "frobnicate"
	329	#:guix-name "minetest-frobnicate"
	330	#:upstream-name "Author/frobnicate"
	331	#:requirements '(("frob" #f
	332	("Author/foo" "Author/bar")))
	333	;; #:sort "score" is the default
	334	#:inputs '("minetest-bar"))
	335	(list #:author "Author" #:name "foo" #:score 0)
	336	(list #:author "Author" #:name "bar" #:score 9999))
	337
2f5368d6	338	(test-package* "minetest->guix-package, ambiguous dependency (most downloads)"
467e874a MD	339	(list #:name "frobnicate"
	340	#:guix-name "minetest-frobnicate"
	341	#:upstream-name "Author/frobnicate"
	342	#:requirements '(("frob" #f
	343	("Author/foo" "Author/bar")))
	344	#:inputs '("minetest-bar")
	345	#:sort "downloads")
	346	(list #:author "Author" #:name "foo" #:downloads 0)
	347	(list #:author "Author" #:name "bar" #:downloads 9999))
	348
	349	(test-package "minetest->guix-package, optional dependency"
	350	#:requirements '(("mesecons" #t
	351	("Jeija/mesecons"
	352	"some-modpack/containing-mese")))
	353	#:inputs '())
	354
8480a2a5 MD	355	;; See e.g. 'orwell/basic_trains'
	356	(test-package* "minetest->guix-package, multiple dependencies implemented by one mod"
	357	(list #:name "frobnicate"
	358	#:guix-name "minetest-frobnicate"
	359	#:upstream-name "Author/frobnicate"
	360	#:requirements '(("frob" #f ("Author/frob"))
	361	("frob_x" #f ("Author/frob")))
	362	#:inputs '("minetest-frob"))
	363	(list #:author "Author" #:name "frob"))
	364
467e874a MD	365	\f
	366	;; License
	367	(test-package "minetest->guix-package, identical licenses"
	368	#:guix-license 'license:lgpl3+
	369	#:license "LGPL-3.0-or-later"
	370	#:media-license "LGPL-3.0-or-later")
	371
	372	;; Sorting
	373	(let* ((make-package
	374	(lambda arguments
	375	(json->package (apply make-package-json arguments))))
	376	(x (make-package #:score 0))
	377	(y (make-package #:score 1))
	378	(z (make-package #:score 2)))
	379	(test-equal "sort-packages, already sorted"
	380	(list z y x)
	381	(sort-packages (list z y x)))
	382	(test-equal "sort-packages, reverse"
	383	(list z y x)
	384	(sort-packages (list x y z))))
	385
085a8a0c MD	386	\f
	387
	388	;; Update detection
	389	(define (upstream-source->sexp upstream-source)
9f526f5d SM	390	(define url (upstream-source-urls upstream-source))
	391	(unless (git-reference? url)
	392	(error "a <git-reference> is expected"))
085a8a0c MD	393	`(,(upstream-source-package upstream-source)
	394	,(upstream-source-version upstream-source)
	395	,(git-reference-url url)
	396	,(git-reference-commit url)))
	397
	398	(define* (expected-sexp #:key
	399	(repo "https://example.org/foo.git")
	400	(guix-name "minetest-foo")
	401	(new-version "0.8")
	402	(commit "44941798d222901b8f381b3210957d880b90a2fc")
	403	#:allow-other-keys)
	404	`(,guix-name ,new-version ,repo ,commit))
	405
	406	(define* (example-package #:key
	407	(source 'auto)
	408	(repo "https://example.org/foo.git")
	409	(old-version "0.8")
	410	(commit "44941798d222901b8f381b3210957d880b90a2fc")
	411	#:allow-other-keys)
	412	(package
	413	(name "minetest-foo")
	414	(version old-version)
	415	(source
	416	(if (eq? source 'auto)
	417	(origin
	418	(method git-fetch)
	419	(uri (git-reference
	420	(url repo)
	421	(commit commit #;"808f9ffbd3106da4c92d2367b118b98196c9e81e")))
	422	(sha256 #f) ; not important for the following tests
	423	(file-name (git-file-name name version)))
	424	source))
	425	(build-system minetest-mod-build-system)
	426	(license #f)
	427	(synopsis #f)
	428	(description #f)
	429	(home-page #f)
	430	(properties '((upstream-name . "Author/foo")))))
	431
	432	(define-syntax-rule (test-release test-case . arguments)
	433	(test-equal test-case
	434	(expected-sexp . arguments)
	435	(and=>
	436	(call-with-packages
	437	(cut latest-minetest-release (example-package . arguments))
	438	(list . arguments))
	439	upstream-source->sexp)))
	440
	441	(define-syntax-rule (test-no-release test-case . arguments)
	442	(test-equal test-case
	443	#f
	444	(call-with-packages
	445	(cut latest-minetest-release (example-package . arguments))
	446	(list . arguments))))
	447
	448	(test-release "same version"
	449	#:old-version "0.8" #:title "0.8" #:new-version "0.8"
	450	#:commit "44941798d222901b8f381b3210957d880b90a2fc")
	451
	452	(test-release "new version (dotted)"
	453	#:old-version "0.8" #:title "0.9.0" #:new-version "0.9.0"
	454	#:commit "c8855b991880897b2658dc90164e29c96e2aeb3a")
	455
	456	(test-release "new version (date)"
457	#:old-version "2014-11-17" #:title "2015-11-04"
458	#:new-version "2015-11-04"
459	#:commit "c8855b991880897b2658dc90164e29c96e2aeb3a")
460
461	(test-release "new version (git -> dotted)"
462	#:old-version
463	(git-version "0.8" "1" "90422555f114d3af35e7cc4b5b6d59a5c226adc4")
464	#:title "0.9.0" #:new-version "0.9.0"
465	#:commit "90422555f114d3af35e7cc4b5b6d59a5c226adc4")
466
467	;; There might actually be a new release, but guix cannot compare dates
468	;; with regular version numbers.
469	(test-no-release "dotted -> date"
470	#:old-version "0.8" #:title "2015-11-04"
471	#:commit "c8855b991880897b2658dc90164e29c96e2aeb3a")
472
473	(test-no-release "date -> dotted"
474	#:old-version "2014-11-07" #:title "0.8"
475	#:commit "c8855b991880897b2658dc90164e29c96e2aeb3a")
476
477	;; Don't let "guix refresh -t minetest" tell there are new versions
478	;; if Guix has insufficient information to actually perform the update,
479	;; when using --with-latest or "guix refresh -u".
480	(test-no-release "no commit information, no new release"
481	#:old-version "0.8" #:title "0.9.0" #:new-version "0.9.0"
482	#:commit #false)
483
484	(test-assert "minetest is not a minetest mod"
485	(not (minetest-package? minetest)))
486	(test-assert "GNU hello is not a minetest mod"
487	(not (minetest-package? hello)))
488	(test-assert "technic is a minetest mod"
489	(minetest-package? minetest-technic))
490	(test-assert "upstream-name is required"
491	(not (minetest-package?
492	(package (inherit minetest-technic)
493	(properties '())))))
494
467e874a	495	(test-end "minetest")
8d4c0e31 MD	496
	497	;;; Local Variables:
	498	;;; eval: (put 'test-package* 'scheme-indent-function 1)
085a8a0c MD	499	;;; eval: (put 'test-release 'scheme-indent-function 1)
085a8a0c MD	500	;;; eval: (put 'test-no-release 'scheme-indent-function 1)
8d4c0e31	501	;;; End: