Toggle diff (189 lines)
diff --git a/Makefile.am b/Makefile.am
index d6aabac261..c10af6155a 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -482,6 +482,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 @@ (define-module (guix import github)
#: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 @@ (define (fetch-releases-or-tags url)
'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")
--
2.34.0
