import/github: Test it.

* Makefile.am (SCM_TESTS): Register new tests.
* guix/import/github.scm
  (%github-api): New variable.
  (fetch-releases-or-tags): Use the new variable.
* tests/import-github.scm: New file with tests.

Signed-off-by: Ludovic Courtès <ludo@gnu.org>

3 files changed, 146 insertions, 3 deletions

diff --git a/Makefile.am b/Makefile.am
index 077586eda7..a10aeb817b 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -483,6 +483,7 @@ SCM_TESTS =					\
   tests/hackage.scm				\
   tests/home-import.scm				\
   tests/import-git.scm				\
+  tests/import-github.scm			\
   tests/import-utils.scm			\
   tests/inferior.scm				\
   tests/lint.scm				\
diff --git a/guix/import/github.scm b/guix/import/github.scm
index 1adfb8d281..8c1898c0c5 100644
--- a/guix/import/github.scm
+++ b/guix/import/github.scm
@@ -39,7 +39,10 @@
   #:use-module (guix upstream)
   #:use-module (guix http-client)
   #:use-module (web uri)
-  #:export (%github-updater))
+  #:export (%github-api %github-updater))
+
+;; For tests.
+(define %github-api (make-parameter "https://api.github.com"))
 
 (define (find-extension url)
   "Return the extension of the archive e.g. '.tar.gz' given a URL, or
@@ -150,11 +153,11 @@ tags show up in the \"Releases\" tab of the web UI.  For instance,
 'https://api.github.com/repos/aconchillo/guile-json/releases' returns the
 empty list."
   (define release-url
-    (string-append "https://api.github.com/repos/"
+    (string-append (%github-api) "/repos/"
                    (github-user-slash-repository url)
                    "/releases"))
   (define tag-url
-    (string-append "https://api.github.com/repos/"
+    (string-append (%github-api) "/repos/"
                    (github-user-slash-repository url)
                    "/tags"))
 
diff --git a/tests/import-github.scm b/tests/import-github.scm
new file mode 100644
index 0000000000..979a0fc12b
--- /dev/null
+++ b/tests/import-github.scm
@@ -0,0 +1,139 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2022 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-import-github)
+  #:use-module (json)
+  #:use-module (srfi srfi-35)
+  #:use-module (srfi srfi-64)
+  #:use-module (guix git-download)
+  #:use-module (guix http-client)
+  #:use-module (guix import github)
+  #:use-module (guix packages)
+  #:use-module (guix tests)
+  #:use-module (guix upstream)
+  #:use-module (ice-9 match))
+
+(test-begin "github")
+
+(define (call-with-releases thunk tags releases)
+  (mock ((guix http-client) http-fetch
+         (lambda* (uri #:key headers)
+           (unless (string-prefix? "mock://" uri)
+             (error "the URI ~a should not be used" uri))
+           (define components
+             (string-split (substring uri 8) #\/))
+           (pk 'stuff components headers)
+           (define (scm->json-port scm)
+             (open-input-string (scm->json-string scm)))
+           (match components
+             (("repos" "foo" "foomatics" "releases")
+              (scm->json-port releases))
+             (("repos" "foo" "foomatics" "tags")
+              (scm->json-port tags))
+             (rest (error "TODO ~a" rest)))))
+        (parameterize ((%github-api "mock://"))
+          (thunk))))
+
+;; Copied from tests/minetest.scm
+(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 new-version new-commit)
+  `("foomatics" ,new-version "https://github.com/foo/foomatics" ,new-commit))
+
+(define (example-package old-version old-commit)
+  (package
+    (name "foomatics")
+    (version old-version)
+    (source
+     (origin
+       (method git-fetch)
+       (uri (git-reference
+             (url "https://github.com/foo/foomatics")
+             (commit old-commit)))
+       (sha256 #f) ; not important for following tests
+       (file-name (git-file-name name version))))
+    (build-system #f)
+    (license #f)
+    (synopsis #f)
+    (description #f)
+    (home-page #f)))
+
+(define* (found-sexp old-version old-commit tags releases)
+  (and=>
+   (call-with-releases (lambda ()
+                         ((upstream-updater-latest %github-updater)
+                          (example-package old-version old-commit)))
+                       tags releases)
+   upstream-source->sexp))
+
+(define-syntax-rule (test-release test-case old-version
+                                  old-commit new-version new-commit
+                                  tags releases)
+  (test-equal test-case
+    (expected-sexp new-version new-commit)
+    (found-sexp old-version old-commit tags releases)))
+
+(test-release "newest release is choosen"
+  "1.0.0" "v1.0.0" "1.9" "v1.9"
+  #()
+  ;; a mixture of current, older and newer versions
+  #((("tag_name" . "v0.0"))
+    (("tag_name" . "v1.0.1"))
+    (("tag_name" . "v1.9"))
+    (("tag_name" . "v1.0.0"))
+    (("tag_name" . "v1.0.2"))))
+
+(test-release "tags are used when there are no formal releases"
+  "1.0.0" "v1.0.0" "1.9" "v1.9"
+  ;; a mixture of current, older and newer versions
+  #((("name" . "v0.0"))
+    (("name" . "v1.0.1"))
+    (("name" . "v1.9"))
+    (("name" . "v1.0.0"))
+    (("name" . "v1.0.2")))
+  #())
+
+(test-release "\"version-\" prefixes are recognised"
+  "1.0.0" "v1.0.0" "1.9" "version-1.9"
+  #((("name" . "version-1.9")))
+  #())
+
+(test-release "prefixes are optional"
+  "1.0.0" "v1.0.0" "1.9" "1.9"
+  #((("name" . "1.9")))
+  #())
+
+(test-release "prefixing by package name is acceptable"
+  "1.0.0" "v1.0.0" "1.9" "foomatics-1.9"
+  #((("name" . "foomatics-1.9")))
+  #())
+
+(test-release "not all prefixes are acceptable"
+  "1.0.0" "v1.0.0" "1.0.0" "v1.0.0"
+  #((("name" . "v1.0.0"))
+    (("name" . "barstatics-1.9")))
+  #())
+
+(test-end "github")