guix-gnunet/tests/contentdb.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-contentdb)
  #:use-module (guix memoization)
  #:use-module (guix import contentdb)
  #:use-module (guix import utils)
  #:use-module (guix tests)
  #:use-module (json)
  #:use-module (ice-9 match)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-64))

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

(define* (make-package-sexp #:key
                            (guix-name "minetest-foo")
                            (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 '())
                            #:allow-other-keys)
  `(package
     (name ,guix-name)
     ;; This is not a proper version number but ContentDB does not include
     ;; version numbers.
     (version "2021-07-25")
     (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)))

(define* (make-package-json #:key
                            (author "Author")
                            (name "foo")
                            (media-license "CC BY-SA 4.0")
                            (license "LGPLv3")
                            (short-description "synopsis")
                            (long-description "description")
                            (repo "https://example.org/foo.git")
                            (website "https://example.org/foo")
                            (forums 321)
                            #:allow-other-keys)
  `(("author" . ,author)
    ("content_warnings" . #())
    ("created_at" . "2018-05-23T19:58:07.422108")
    ("downloads" . 123)
    ("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" . ,987.654)
    ("screenshots" . #())
    ("short_description" . ,short-description)
    ("state" . "APPROVED")
    ("tags" . #("some" "tags"))
    ("thumbnail" . null)
    ("title" . "The name")
    ("type" . "mod")
    ("url" . ,(string-append "https://content.minetest.net/packages/"
                             author "/" name "/download/"))
    ("website" . ,website)))

(define* (make-releases-json #:key (commit #f) (title "") #: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" . "2021-07-25"))))

(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 (call-with-packages thunk . 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 #\/))
           (unless (>= (length components) 2)
             (error "the URL ~a should have an author and name component" url))
           (define requested-author (list-ref components 0))
           (define requested-name (list-ref components 1))
           (define rest (cddr components))
           (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))
           (define (scm->json-port scm)
             (open-input-string (scm->json-string scm)))
           (scm->json-port
            (apply (match rest
                     (("") make-package-json)
                     (("dependencies" "") make-dependencies-json)
                     (("releases" "") make-releases-json)
                     (_ (error "TODO ~a" rest)))
                   relevant-argument-list))))
        (parameterize ((%contentdb-api "mock://api/"))
          (thunk))))

(define* (contentdb->guix-package* #:key (author "Author") (name "foo")
                                   #:allow-other-keys)
  (contentdb->guix-package author name))

(define (imported-package-sexp . extra-arguments)
  (call-with-packages
   (lambda ()
     ;; Don't reuse results from previous tests.
     (invalidate-memoization! contentdb->guix-package)
     (apply contentdb->guix-package* extra-arguments))
   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)))

(test-begin "contentdb")


;; Package names
(test-package "contentdb->guix-package")
(test-package "contentdb->guix-package, _ → - in package name"
              #:name "foo_bar"
              #:guix-name "minetest-foo-bar")


;; Determining the home page
(test-package "contentdb->guix-package, website is used as home page"
              #:home-page "web://site"
              #:website "web://site")
(test-package "contentdb->guix-package, if absent, the forum is used"
              #:home-page '(minetest-topic 628)
              #:forums 628
              #:website 'null)
(test-package "contentdb->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 "contentdb->guix-package, all home page information absent"
              #:home-page #f
              #:forums 'null
              #:website 'null
              #:repo 'null)



;; Dependencies
(test-package "contentdb->guix-package, dependency"
              #:requirements '(("mesecons" #f
                                ("Jeija/mesecons"
                                 "some-modpack/containing-mese")))
              #:inputs '("minetest-mesecons"))

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


;; License
(test-package "contentdb->guix-package, identical licenses"
              #:guix-license 'license:lgpl3
              #:license "LGPLv3"
              #:media-license "LGPLv3")

(test-end "contentdb")