amaharaneko/guix-mirrors
1
1
Fork 0
mirror of https://codeberg.org/guix/guix.git synced 2025-10-02 02:15:12 +00:00
Code Issues Projects Releases Packages Wiki Activity Actions

import/github: Return <git-reference> objects for git-fetch origins.

Browse source 
* guix/import/github.scm
  (latest-released-version): Also return the tag.
  (latest-release): Use this information to return <git-reference> objects
  when appropriate.

Signed-off-by: Ludovic Courtès <ludo@gnu.org>
This commit is contained in:
Maxime Devos 2022-01-06 20:50:11 +00:00 • committed by Ludovic Courtès
parent 084b76a70a
commit f8306a5019
No known key found for this signature in database
GPG key ID: 090B11993D9AEBB5
1 changed files with 27 additions and 16 deletions
Download patch file Download diff file Expand all files Collapse all files

41
guix/import/github.scm
View file

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