kreyren/guix-kreyren
1
0
Fork 0
Code Issues 1 Pull Requests 1 Releases Activity

upstream: Support updating and fetching 'git-fetch' origins.

Browse Source 
Updaters need to be modified to return 'git-reference' objects.
This patch modifies the 'generic-git' and 'minetest' updater,
but others might need to be modified as well.

* guix/git.scm (git-reference->git-checkout): New procedure.
* guix/upstream.scm (package-update/git-fetch): New procedure.
  (<upstream-source>)[urls]: Document it can be a 'git-reference'.
  (%method-updates): Add 'git-fetch' mapping.
  (update-package-source): Support 'git-reference' sources.
  (upstream-source-compiler/url-fetch): Split off from ...
  (upstream-source-compiler): ... this, and call ...
  (upstream-source-compiler/git-fetch): ... this new procedure if the URL
  field contains a 'git-reference'.
* guix/import/git.scm
  (latest-git-tag-version): Always return two values and document that the tag
  is returned as well.
  (latest-git-release)[urls]: Use the 'git-reference' instead of the
  repository URL.
* guix/import/minetest.scm (latest-minetest-release)[urls]: Don't wrap the
  'git-reference' in a list.
* tests/minetest.scm (upstream-source->sexp): Adjust to new convention.

Co-authored-by: Maxime Devos <maximedevos@telenet.be>
Signed-off-by: Ludovic Courtès <ludo@gnu.org>
This commit is contained in:
Sarah Morgensen 2022-01-05 14:07:50 +00:00 committed by Ludovic Courtès
parent 1c32b4c965
commit 9f526f5dad
No known key found for this signature in database
GPG Key ID: 090B11993D9AEBB5
5 changed files with 98 additions and 24 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

14
guix/git.scm
View File

@ -3,6 +3,7 @@
;;; Copyright © 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2021 Kyle Meyer <kyle@kyleam.com>
;;; Copyright © 2021 Marius Bakke <marius@gnu.org>
;;; Copyright © 2022 Maxime Devos <maximedevos@telenet.be>
;;;
;;; This file is part of GNU Guix.
;;;
@ -33,6 +34,8 @@
#:use-module (guix utils)
#:use-module (guix records)
#:use-module (guix gexp)
#:autoload (guix git-download)
(git-reference-url git-reference-commit git-reference-recursive?)
#:use-module (guix sets)
#:use-module ((guix diagnostics) #:select (leave warning))
#:use-module (guix progress)
@ -65,7 +68,9 @@
git-checkout-url
git-checkout-branch
git-checkout-commit
git-checkout-recursive?))
git-checkout-recursive?
git-reference->git-checkout))
(define %repository-cache-directory
(make-parameter (string-append (cache-directory #:ensure? #f)
@ -672,6 +677,13 @@ is true, limit to only refs/tags."
(commit git-checkout-commit (default #f)) ;#f | tag | commit
(recursive? git-checkout-recursive? (default #f)))
(define (git-reference->git-checkout reference)
"Convert the <git-reference> REFERENCE to an equivalent <git-checkout>."
(git-checkout
(url (git-reference-url reference))
(commit (git-reference-commit reference))
(recursive? (git-reference-recursive? reference))))
(define* (latest-repository-commit* url #:key ref recursive? log-port)
;; Monadic variant of 'latest-repository-commit'.
(lambda (store)

22
guix/import/git.scm
View File

@ -1,6 +1,7 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz>
;;; Copyright © 2021 Sarah Morgensen <iskarian@mgsn.dev>
;;; Copyright © 2022 Maxime Devos <maximedevos@telenet.be>
;;;
;;; This file is part of GNU Guix.
;;;
@ -34,6 +35,7 @@
#:use-module (srfi srfi-26)
#:use-module (srfi srfi-34)
#:use-module (srfi srfi-35)
#:use-module (srfi srfi-71)
#:export (%generic-git-updater
;; For tests.
@ -172,21 +174,21 @@ repository at URL."
(values version tag)))))))
(define (latest-git-tag-version package)
"Given a PACKAGE, return the latest version of it, or #f if the latest version
could not be determined."
"Given a PACKAGE, return the latest version of it and the corresponding git
tag, or #false and #false if the latest version could not be determined."
(guard (c ((or (git-no-tags-error? c) (git-no-valid-tags-error? c))
(warning (or (package-field-location package 'source)
(package-location package))
(G_ "~a for ~a~%")
(condition-message c)
(package-name package))
#f)
(values #f #f))
((eq? (exception-kind c) 'git-error)
(warning (or (package-field-location package 'source)
(package-location package))
(G_ "failed to fetch Git repository for ~a~%")
(package-name package))
#f))
(values #f #f)))
(let* ((source (package-source package))
(url (git-reference-url (origin-uri source)))
(property (cute assq-ref (package-properties package) <>)))
@ -208,14 +210,16 @@ could not be determined."
"Return an <upstream-source> for the latest release of PACKAGE."
(let* ((name (package-name package))
(old-version (package-version package))
(url (git-reference-url (origin-uri (package-source package))))
(new-version (latest-git-tag-version package)))
(and new-version
(old-reference (origin-uri (package-source package)))
(new-version new-version-tag (latest-git-tag-version package)))
(and new-version new-version-tag
(upstream-source
(package name)
(version new-version)
(urls (list url))))))
(urls (git-reference
(url (git-reference-url old-reference))
(commit new-version-tag)
(recursive? (git-reference-recursive? old-reference))))))))
(define %generic-git-updater
(upstream-updater

6
guix/import/minetest.scm
View File

@ -504,9 +504,9 @@ or #false if the latest release couldn't be determined."
(upstream-source
(package (package:package-name pkg))
(version (release-version release))
(urls (list (download:git-reference
(url (package-repository contentdb-package))
(commit (release-commit release))))))))
(urls (download:git-reference
(url (package-repository contentdb-package))
(commit (release-commit release)))))))
(define %minetest-updater
(upstream-updater

73
guix/upstream.scm
View File

@ -2,6 +2,8 @@
;;; Copyright © 2010, 2011, 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2015 Alex Kost <alezost@gmail.com>
;;; Copyright © 2019, 2022 Ricardo Wurmus <rekado@elephly.net>
;;; Copyright © 2021 Sarah Morgensen <iskarian@mgsn.dev>
;;; Copyright © 2021, 2022 Maxime Devos <maximedevos@telenet.be>
;;;
;;; This file is part of GNU Guix.
;;;
@ -24,12 +26,15 @@
#:use-module (guix discovery)
#:use-module ((guix download)
#:select (download-to-store url-fetch))
#:use-module (guix git-download)
#:use-module (guix gnupg)
#:use-module (guix packages)
#:use-module (guix diagnostics)
#:use-module (guix ui)
#:use-module (guix base32)
#:use-module (guix gexp)
#:autoload (guix git) (latest-repository-commit git-reference->git-checkout)
#:use-module (guix hash)
#:use-module (guix store)
#:use-module ((guix derivations) #:select (built-derivations derivation->output-path))
#:autoload (gcrypt hash) (port-sha256)
@ -93,7 +98,7 @@
upstream-source?
(package upstream-source-package) ;string
(version upstream-source-version) ;string
(urls upstream-source-urls) ;list of strings
(urls upstream-source-urls) ;list of strings|git-reference
(signature-urls upstream-source-signature-urls ;#f | list of strings
(default #f))
(input-changes upstream-source-input-changes
@ -363,10 +368,9 @@ values: 'interactive' (default), 'always', and 'never'."
data url)
#f)))))))
(define-gexp-compiler (upstream-source-compiler (source <upstream-source>)
system target)
"Download SOURCE from its first URL and lower it as a fixed-output
derivation that would fetch it."
(define (upstream-source-compiler/url-fetch source system)
"Lower SOURCE, an <upstream-source> pointing to a tarball, as a
fixed-output derivation that would fetch it, and verify its authenticity."
(mlet* %store-monad ((url -> (first (upstream-source-urls source)))
(signature
-> (and=> (upstream-source-signature-urls source)
@ -384,6 +388,30 @@ derivation that would fetch it."
(url-fetch url 'sha256 hash (store-path-package-name tarball)
#:system system))))
(define (upstream-source-compiler/git-fetch source system)
"Lower SOURCE, an <upstream-source> using git, as a fixed-output
derivation that would fetch it."
(mlet* %store-monad ((reference -> (upstream-source-urls source))
(checkout
(lower-object
(git-reference->git-checkout reference)
system)))
;; Like in 'upstream-source-compiler/url-fetch', return a fixed-output
;; derivation instead of CHECKOUT.
(git-fetch reference 'sha256
(file-hash* checkout #:recursive? #true #:select? (const #true))
(git-file-name (upstream-source-package source)
(upstream-source-version source))
#:system system)))
(define-gexp-compiler (upstream-source-compiler (source <upstream-source>)
system target)
"Download SOURCE, lower it as a fixed-output derivation that would fetch it,
and verify its authenticity if possible."
(if (git-reference? (upstream-source-urls source))
(upstream-source-compiler/git-fetch source system)
(upstream-source-compiler/url-fetch source system)))
(define (find2 pred lst1 lst2)
"Like 'find', but operate on items from both LST1 and LST2. Return two
values: the item from LST1 and the item from LST2 that match PRED."
@ -436,9 +464,24 @@ SOURCE, an <upstream-source>."
#:key-download key-download)))
(values version tarball source))))))
(define* (package-update/git-fetch store package source #:key key-download)
"Return the version, checkout, and SOURCE, to update PACKAGE to
SOURCE, an <upstream-source>."
;; TODO: it would be nice to authenticate commits, e.g. with
;; "guix git authenticate" or a list of permitted signing keys.
(define ref (upstream-source-urls source)) ; a <git-reference>
(values (upstream-source-version source)
(latest-repository-commit
store
(git-reference-url ref)
#:ref `(tag-or-commit . ,(git-reference-commit ref))
#:recursive? (git-reference-recursive? ref))
source))
(define %method-updates
;; Mapping of origin methods to source update procedures.
`((,url-fetch . ,package-update/url-fetch)))
`((,url-fetch . ,package-update/url-fetch)
(,git-fetch . ,package-update/git-fetch)))
(define* (package-update store package
#:optional (updaters (force %updaters))
@ -498,9 +541,22 @@ new version string if an update was made, and #f otherwise."
(origin-hash (package-source package))))
(old-url (match (origin-uri (package-source package))
((? string? url) url)
((? git-reference? ref)
(git-reference-url ref))
(_ #f)))
(new-url (match (upstream-source-urls source)
((first _ ...) first)))
((first _ ...) first)
((? git-reference? ref)
(git-reference-url ref))
(_ #f)))
(old-commit (match (origin-uri (package-source package))
((? git-reference? ref)
(git-reference-commit ref))
(_ #f)))
(new-commit (match (upstream-source-urls source)
((? git-reference? ref)
(git-reference-commit ref))
(_ #f)))
(file (and=> (location-file loc)
(cut search-path %load-path <>))))
(if file
@ -514,6 +570,9 @@ new version string if an update was made, and #f otherwise."
'filename file))
(replacements `((,old-version . ,version)
(,old-hash . ,hash)
,@(if (and old-commit new-commit)
`((,old-commit . ,new-commit))
'())
,@(if (and old-url new-url)
`((,(dirname old-url) .
,(dirname new-url)))

7
tests/minetest.scm
View File

@ -387,10 +387,9 @@ during a dynamic extent where that package is available on ContentDB."
;; Update detection
(define (upstream-source->sexp upstream-source)
(define urls (upstream-source-urls upstream-source))
(unless (= 1 (length urls))
(error "only a single URL is expected"))
(define url (first urls))
(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)