[bug#53060] [PATCH 0/2] Allow the github updater to update git sources

[bug#53060] [PATCH 0/2] Allow the github updater to update git sources

[Maxime Devos]

[-- Attachment #1: Type: text/plain, Size: 295 bytes --]

Follow-up to <https://issues.guix.gnu.org/50072>.

To test, you can do

$ make check
$ ./pre-inst-env guix refresh -t github -u zig

and verify that the version and sha256/base32 has been updated
(zig@0.9.0 doesn't work though; patches aren't applying cleanly).

Greetings,
Maxime.

[-- Attachment #2: This is a digitally signed message part --]
[-- Type: application/pgp-signature, Size: 260 bytes --]

[bug#53060] [PATCH 1/2] import/github: Return <git-reference> objects for git-fetch origins.

[Maxime Devos]

* guix/import/github.scm
  (latest-released-version): Also return the tag.
  (latest-release): Use this information to return <git-reference> objects
  when appropriate.
---
 guix/import/github.scm | 43 ++++++++++++++++++++++++++----------------
 1 file changed, 27 insertions(+), 16 deletions(-)

diff --git a/guix/import/github.scm b/guix/import/github.scm
index 888b148ffb..1adfb8d281 100644
--- a/guix/import/github.scm
+++ b/guix/import/github.scm
@@ -4,6 +4,7 @@
 ;;; Copyright © 2018 Eric Bavier <bavier@member.fsf.org>
 ;;; Copyright © 2019 Arun Isaac <arunisaac@systemreboot.net>
 ;;; Copyright © 2019 Efraim Flashner <efraim@flashner.co.il>
+;;; Copyright © 2022 Maxime Devos <maximedevos@telenet.be>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -25,6 +26,7 @@ (define-module (guix import github)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-26)
   #:use-module (srfi srfi-34)
+  #:use-module (srfi srfi-71)
   #:use-module (guix utils)
   #:use-module (guix i18n)
   #:use-module (guix diagnostics)
@@ -181,12 +183,15 @@ (define headers
         (x x)))))
 
 (define (latest-released-version url package-name)
-  "Return a string of the newest released version name given a string URL like
+  "Return the newest released version and its tag given a string URL like
 'https://github.com/arq5x/bedtools2/archive/v2.24.0.tar.gz' and the name of
-the package e.g. 'bedtools2'.  Return #f if there is no releases"
+the package e.g. 'bedtools2'.  Return #f (two values) if there are no
+releases."
   (define (pre-release? x)
     (assoc-ref x "prerelease"))
 
+  ;; This procedure returns (version . tag) pair, or #f
+  ;; if RELEASE doesn't seyem to correspond to a version.
   (define (release->version release)
     (let ((tag (or (assoc-ref release "tag_name") ;a "release"
                    (assoc-ref release "name")))   ;a tag
@@ -197,22 +202,22 @@ (define (release->version release)
        ((and (< name-length (string-length tag))
              (string=? (string-append package-name "-")
                        (substring tag 0 (+ name-length 1))))
-        (substring tag (+ name-length 1)))
+        (cons (substring tag (+ name-length 1)) tag))
        ;; some tags start with a "v" e.g. "v0.25.0"
        ;; or with the word "version" e.g. "version.2.1"
        ;; where some are just the version number
        ((string-prefix? "version" tag)
-        (if (char-set-contains? char-set:digit (string-ref tag 7))
-            (substring tag 7)
-            (substring tag 8)))
+        (cons (if (char-set-contains? char-set:digit (string-ref tag 7))
+                  (substring tag 7)
+                  (substring tag 8)) tag))
        ((string-prefix? "v" tag)
-        (substring tag 1))
+        (cons (substring tag 1) tag))
        ;; Finally, reject tags that don't start with a digit:
        ;; they may not represent a release.
        ((and (not (string-null? tag))
              (char-set-contains? char-set:digit
                                  (string-ref tag 0)))
-        tag)
+        (cons tag tag))
        (else #f))))
 
   (let* ((json (and=> (fetch-releases-or-tags url)
@@ -229,14 +234,14 @@ (define (release->version release)
                                  (match (remove pre-release? json)
                                    (() json) ; keep everything
                                    (releases releases)))
-                     version>?)
-          ((latest-release . _) latest-release)
-          (() #f)))))
+                     (lambda (x y) (version>? (car x) (car y))))
+          (((latest-version . tag) . _) (values latest-version tag))
+          (() (values #f #f))))))
 
 (define (latest-release pkg)
   "Return an <upstream-source> for the latest release of PKG."
-  (define (origin-github-uri origin)
-    (match (origin-uri origin)
+  (define (github-uri uri)
+    (match uri
       ((? string? url)
        url)                                       ;surely a github.com URL
       ((? download:git-reference? ref)
@@ -244,14 +249,20 @@ (define (origin-github-uri origin)
       ((urls ...)
        (find (cut string-contains <> "github.com") urls))))
 
-  (let* ((source-uri (origin-github-uri (package-source pkg)))
+  (let* ((original-uri (origin-uri (package-source pkg)))
+         (source-uri (github-uri original-uri))
          (name (package-name pkg))
-         (newest-version (latest-released-version source-uri name)))
+         (newest-version version-tag
+                         (latest-released-version source-uri name)))
     (if newest-version
         (upstream-source
          (package name)
          (version newest-version)
-         (urls (list (updated-github-url pkg newest-version))))
+         (urls (if (download:git-reference? original-uri)
+                   (download:git-reference
+                    (inherit original-uri)
+                    (commit version-tag))
+                   (list (updated-github-url pkg newest-version)))))
         #f))) ; On GitHub but no proper releases
 
 (define %github-updater

base-commit: 90bc18bcd4d221b53e52f94039d256d2a8edea5b
prerequisite-patch-id: 2888bb74d524c7eee9edef94c8f06f099291e7d9
prerequisite-patch-id: 24d16d7354ddca4822f631a883c8e8789c818533
prerequisite-patch-id: ab72bad504c2df472d539b6a8205fed9c89416ab
prerequisite-patch-id: 8c91ca86901e3f61d1363d521fa825ac680f60d8
-- 
2.34.0

[bug#53060] [PATCH 2/2] import/github: Test it.

[Maxime Devos]

* 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.
---
 Makefile.am             |   1 +
 guix/import/github.scm  |   9 ++-
 tests/import-github.scm | 139 ++++++++++++++++++++++++++++++++++++++++
 3 files changed, 146 insertions(+), 3 deletions(-)
 create mode 100644 tests/import-github.scm

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

[bug#53060] [PATCH 0/2] Allow the github updater to update git sources

[Ludovic Courtès]

Hi,

Maxime Devos <maximedevos@telenet.be> skribis:

> Follow-up to <https://issues.guix.gnu.org/50072>.
>
> To test, you can do
>
> $ make check
> $ ./pre-inst-env guix refresh -t github -u zig
>
> and verify that the version and sha256/base32 has been updated
> (zig@0.9.0 doesn't work though; patches aren't applying cleanly).

Nice, applied!

One comment:

> +(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))))

I think the whole point of having the ‘%github-api’ parameter is that it
allows us to mock the HTTP server instead of having to override bindings
such as ‘http-fetch’.

I’d have a slight preference for doing that, similar to what is done in
tests/cpan.scm for instance.  WDYT?

Thanks,
Ludo’.

[bug#53060] [PATCH 0/2] Allow the github updater to update git sources

[Maxime Devos]

[-- Attachment #1: Type: text/plain, Size: 1925 bytes --]

Ludovic Courtès schreef op zo 16-01-2022 om 23:19 [+0100]:
> Hi,
> 
> Maxime Devos <maximedevos@telenet.be> skribis:
> 
> > Follow-up to <https://issues.guix.gnu.org/50072>.
> > 
> > To test, you can do
> > 
> > $ make check
> > $ ./pre-inst-env guix refresh -t github -u zig
> > 
> > and verify that the version and sha256/base32 has been updated
> > (zig@0.9.0 doesn't work though; patches aren't applying cleanly).
> 
> Nice, applied!
> 
> One comment:
> 
> > +(define (call-with-releases thunk tags releases)
> > +  (mock ((guix http-client) http-fetch [...])
> > +        (parameterize ((%github-api "mock://"))
> > +          (thunk))))
> 
> I think the whole point of having the ‘%github-api’ parameter is that it
> allows us to mock the HTTP server instead of having to override bindings
> such as ‘http-fetch’.
> 
> I’d have a slight preference for doing that, similar to what is done in
> tests/cpan.scm for instance.  WDYT?

tests/cpan.scm uses 'with-http-server', which I do not find ideal
because the answers the HTTP server gives depend on the order the
HTTP server was queried, without verifying the URI.  Mocking
'http-fetch' allows me not to worry about ordering and allows verifying
the URI.

It might be possible to modify 'with-http-server' into something
(with-http-server*?) that allows looking at the HTTP headers and URI
and dynamically generate a response based on that.

Due to the mocking, %github-api isn't truly necessary, but having
"https://api.github.com" in a single location helps avoiding typos
like writing "http://" instead of "https://" somewhere, or adjusting
the domain name if GitHub decided to change it for whatever reason
(hopefully unlikely?), or if Tor becomes very popular among the general
public and GitHub has an ".onion" address, then it could be changed to
the ".onion" address easily, ...

Greetings,
Maxime.

[-- Attachment #2: This is a digitally signed message part --]
[-- Type: application/pgp-signature, Size: 260 bytes --]

[bug#53060] [PATCH 0/2] Allow the github updater to update git sources

[Ludovic Courtès]

Hi,

Maxime Devos <maximedevos@telenet.be> skribis:

> tests/cpan.scm uses 'with-http-server', which I do not find ideal
> because the answers the HTTP server gives depend on the order the
> HTTP server was queried, without verifying the URI.  Mocking
> 'http-fetch' allows me not to worry about ordering and allows verifying
> the URI.

Good point.

> It might be possible to modify 'with-http-server' into something
> (with-http-server*?) that allows looking at the HTTP headers and URI
> and dynamically generate a response based on that.

Yes, that’d be great.

> Due to the mocking, %github-api isn't truly necessary, but having
> "https://api.github.com" in a single location helps avoiding typos
> like writing "http://" instead of "https://" somewhere, or adjusting
> the domain name if GitHub decided to change it for whatever reason
> (hopefully unlikely?), or if Tor becomes very popular among the general
> public and GitHub has an ".onion" address, then it could be changed to
> the ".onion" address easily, ...

Yes, and also, setting ‘%github-api’ makes sure we don’t inadvertently
talk to the real GitHub (there was a bug along these lines in the tests
of one of the importers a while back.)

Thanks,
Ludo’.