[PATCH 00/12] Better source code recovery from SWH

  • Done
  • quality assurance status badge
Details
3 participants
  • Ludovic Courtès
  • Timothy Sample
  • Simon Tournier
Owner
unassigned
Submitted by
Ludovic Courtès
Severity
normal
L
L
Ludovic Courtès wrote on 23 Feb 15:22 +0100
(address . guix-patches@gnu.org)(name . Ludovic Courtès)(address . ludo@gnu.org)
cover.1708697539.git.ludo@gnu.org
Hello Guix!

This patch series improves source code recovery from SWH, as a followup

It does several things:

• ‘guix lint -c archival’ now emits save requests for VCSes other
than Git.


• Allow content-addressed recovery of Mercurial and Subversion
checkouts.

• Allow Bazaar recovery using ‘download-nar’ (I didn’t bother with SWH).

• Have all these things honor the ‘GUIX_DOWNLOAD_SEQUENCE’ environment
variable.

You can try the various methods like this:

GUIX_DOWNLOAD_SEQUENCE=nar ./pre-inst-env guix build -S apl --check
GUIX_DOWNLOAD_SEQUENCE=swh ./pre-inst-env guix build -S guile-wisp --check
GUIX_DOWNLOAD_SEQUENCE=swh ./pre-inst-env guix build -S guile-gcrypt --check

In the last case, note that you must be running guix-daemon for the checkout
since that uses “builtin:git-download”, which is implemented on the server
side.

There’s a few caveats:

• Mercurial SWH fallback almost works, but not quite, due to this SWH bug:

• Right now, no Subversion checkout has the nar-sha256 ExtID at SWH for
unclear reasons, so retrieving the source of ‘apl’ (say) from SWH
doesn’t work yet.

• Multi-directory Subversion downloads (‘svn-multi-fetch’) is not supported
yet. For that we’ll need to arrange with our SWH friends so they
compute nar-sha256 ExtIDs for combined directories (and we’ll have to
include that info in ‘sources.json’).

Feedback welcome!

Ludo’.

Ludovic Courtès (12):
lint: Switch to SRFI-71.
lint: archival: Fix crash in non-Git case.
lint: archival: Trigger “Save Code Now” for VCSes other than Git.
swh: Add ‘type’ field to <visit>.
swh: ‘origin-visits’ takes an optional ‘max’ parameter.
swh: ‘lookup-origin-revision’ handles branches pointing to
directories.
hg-download: Use ‘swh-download-directory-by-nar-hash’.
svn-download: Use ‘swh-download-directory-by-nar-hash’.
bzr-download: Implement nar fallback.
download-nar: Distinguish ‘output’ and ‘item’ parameter.
perform-download: Allow use of ‘download-nar’ for ‘--check’ builds.
download: Honor ‘GUIX_DOWNLOAD_SEQUENCE’ environment variable.

guix/build/bzr.scm | 3 +-
guix/build/download-nar.scm | 12 +--
guix/build/download.scm | 50 +++++++---
guix/build/git.scm | 27 ++++--
guix/bzr-download.scm | 57 ++++++++---
guix/cvs-download.scm | 24 +++--
guix/download.scm | 53 ++++-------
guix/git-download.scm | 20 ++--
guix/hg-download.scm | 36 ++++---
guix/lint.scm | 151 +++++++++++++++++++-----------
guix/scripts/perform-download.scm | 65 +++++++------
guix/svn-download.scm | 84 +++++++++++------
guix/swh.scm | 71 ++++++++------
tests/lint.scm | 20 ++++
tests/swh.scm | 74 +++++++++++++++
15 files changed, 501 insertions(+), 246 deletions(-)


base-commit: ffcce77ec488e3c89401ad77fafa65fcd9e9f5be
--
2.41.0
L
L
Ludovic Courtès wrote on 23 Feb 16:48 +0100
[PATCH 09/12] bzr-download: Implement nar fallback.
(address . 69328@debbugs.gnu.org)(name . Ludovic Courtès)(address . ludo@gnu.org)
4e0514fe0f56873a54c4d79245813274a01cbb5b.1708697539.git.ludo@gnu.org
* guix/bzr-download.scm (bzr-fetch)[guile-json, guile-lzlib,
guile-gnutls]: New variables.
[build]: Add ‘with-extensions’ and import more modules. Invoke
‘download-nar’ when ‘bzr-fetch’ returns #f.
* guix/build/bzr.scm (bzr-fetch): Actually return #t on success.

Change-Id: Id5d4ebd0f9ddc3c44b6456d3b46c0000cc7b9997
---
guix/build/bzr.scm | 3 ++-
guix/bzr-download.scm | 43 ++++++++++++++++++++++++++++++++-----------
2 files changed, 34 insertions(+), 12 deletions(-)

Toggle diff (86 lines)
diff --git a/guix/build/bzr.scm b/guix/build/bzr.scm
index a0f5e15880..dede5e031a 100644
--- a/guix/build/bzr.scm
+++ b/guix/build/bzr.scm
@@ -37,6 +37,7 @@ (define* (bzr-fetch url revision directory
(invoke bzr-command "-Ossl.cert_reqs=none" "checkout"
"--lightweight" "-r" revision url directory)
(with-directory-excursion directory
- (delete-file-recursively ".bzr")))
+ (delete-file-recursively ".bzr"))
+ #t)
;;; bzr.scm ends here
diff --git a/guix/bzr-download.scm b/guix/bzr-download.scm
index d97f84838e..01c12fd54d 100644
--- a/guix/bzr-download.scm
+++ b/guix/bzr-download.scm
@@ -1,5 +1,6 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2017, 2022 Maxim Cournoyer <maxim.cournoyer@gmail.com>
+;;; Copyright © 2024 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -51,20 +52,40 @@ (define (bzr-package)
(module-ref distro 'breezy)))
(define* (bzr-fetch ref hash-algo hash
- #:optional name
- #:key (system (%current-system)) (guile (default-guile))
- (bzr (bzr-package)))
+ #:optional name
+ #:key (system (%current-system)) (guile (default-guile))
+ (bzr (bzr-package)))
"Return a fixed-output derivation that fetches REF, a <bzr-reference>
object. The output is expected to have recursive hash HASH of type
HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #f."
+ (define guile-json
+ (module-ref (resolve-interface '(gnu packages guile)) 'guile-json-4))
+
+ (define guile-lzlib
+ (module-ref (resolve-interface '(gnu packages guile)) 'guile-lzlib))
+
+ (define guile-gnutls
+ (module-ref (resolve-interface '(gnu packages tls)) 'guile-gnutls))
+
(define build
- (with-imported-modules (source-module-closure
- '((guix build bzr)))
- #~(begin
- (use-modules (guix build bzr))
- (bzr-fetch
- (getenv "bzr url") (getenv "bzr reference") #$output
- #:bzr-command (string-append #+bzr "/bin/brz")))))
+ (with-extensions (list guile-gnutls guile-lzlib guile-json)
+ (with-imported-modules (source-module-closure
+ '((guix build bzr)
+ (guix build utils)
+ (guix build download-nar)))
+ #~(begin
+ (use-modules (guix build bzr)
+ (guix build download-nar)
+ (guix build utils)
+ (srfi srfi-34))
+
+ (or (guard (c ((invoke-error? c)
+ (report-invoke-error c)
+ #f))
+ (bzr-fetch (getenv "bzr url") (getenv "bzr reference")
+ #$output
+ #:bzr-command (string-append #+bzr "/bin/brz")))
+ (download-nar #$output))))))
(mlet %store-monad ((guile (package->derivation guile system)))
(gexp->derivation (or name "bzr-branch") build
@@ -79,7 +100,7 @@ (define* (bzr-fetch ref hash-algo hash
"LC_ALL" "LC_MESSAGES" "LANG"
"COLUMNS")
#:system system
- #:local-build? #t ;don't offload repo branching
+ #:local-build? #t ;don't offload repo branching
#:hash-algo hash-algo
#:hash hash
#:recursive? #t
--
2.41.0
L
L
Ludovic Courtès wrote on 23 Feb 16:48 +0100
[PATCH 05/12] swh: ‘origin-visits’ takes an optional ‘max’ parameter.
(address . 69328@debbugs.gnu.org)(name . Ludovic Courtès)(address . ludo@gnu.org)
61e6c1cb658fb29ec0a55aca5b57f65597c4ac41.1708697539.git.ludo@gnu.org
* guix/swh.scm (origin-visits): Add optional ‘max’ parameter and honor
it.

Change-Id: I642d7d4b0672b68fb5c7ce2b49161307e13d3c95
---
guix/swh.scm | 9 +++++----
1 file changed, 5 insertions(+), 4 deletions(-)

Toggle diff (22 lines)
diff --git a/guix/swh.scm b/guix/swh.scm
index 83f67423c8..14c65f6806 100644
--- a/guix/swh.scm
+++ b/guix/swh.scm
@@ -474,10 +474,11 @@ (define* (lookup-directory-by-nar-hash hash #:optional (algorithm 'sha256))
hash)
external-id-target))
-(define (origin-visits origin)
- "Return the list of visits of ORIGIN, a record as returned by
-'lookup-origin'."
- (call (swh-url (origin-visits-url origin))
+(define* (origin-visits origin #:optional (max 10))
+ "Return the list of the up to MAX latest visits of ORIGIN, a record as
+returned by 'lookup-origin'."
+ (call (string-append (swh-url (origin-visits-url origin))
+ "?per_page=" (number->string max))
(lambda (port)
(map json->visit (vector->list (json->scm port))))))
--
2.41.0
L
L
Ludovic Courtès wrote on 23 Feb 16:48 +0100
[PATCH 11/12] perform-download: Allow use of ‘download-nar’ for ‘--check ’ builds.
(address . 69328@debbugs.gnu.org)(name . Ludovic Courtès)(address . ludo@gnu.org)
25d47583dc9bf21ef918ae400de80fa58e09602c.1708697539.git.ludo@gnu.org
Previously, the nar fallback would always fail on ‘--check’ build
because the output directory in that case is different from the store
file name. This change fixes that.

* guix/build/git.scm (git-fetch-with-fallback): Add #:item parameter and
pass it to ‘download-nar’.
* guix/scripts/perform-download.scm (perform-git-download): Pass #:item
to ‘git-fetch-with-fallback’.

Change-Id: I30fc948718e99574005150bba5215a51ef153c49
---
guix/build/git.scm | 14 ++++++++------
guix/scripts/perform-download.scm | 3 +++
2 files changed, 11 insertions(+), 6 deletions(-)

Toggle diff (52 lines)
diff --git a/guix/build/git.scm b/guix/build/git.scm
index 4c69365a7b..a135026fae 100644
--- a/guix/build/git.scm
+++ b/guix/build/git.scm
@@ -92,19 +92,21 @@ (define* (git-fetch url commit directory
(define* (git-fetch-with-fallback url commit directory
- #:key (git-command "git")
+ #:key (item directory)
+ (git-command "git")
hash hash-algorithm
lfs? recursive?)
"Like 'git-fetch', fetch COMMIT from URL into DIRECTORY, but fall back to
-alternative methods when fetching from URL fails: attempt to download a nar,
-and if that also fails, download from the Software Heritage archive. When
-HASH and HASH-ALGORITHM are provided, they are interpreted as the nar hash of
-the directory of interested and are used as its content address at SWH."
+alternative methods when fetching from URL fails: attempt to download a nar
+for ITEM, and if that also fails, download from the Software Heritage archive.
+When HASH and HASH-ALGORITHM are provided, they are interpreted as the nar
+hash of the directory of interested and are used as its content address at
+SWH."
(or (git-fetch url commit directory
#:lfs? lfs?
#:recursive? recursive?
#:git-command git-command)
- (download-nar directory)
+ (download-nar item directory)
;; As a last resort, attempt to download from Software Heritage.
;; Disable X.509 certificate verification to avoid depending
diff --git a/guix/scripts/perform-download.scm b/guix/scripts/perform-download.scm
index e7eb3b2a1f..b96959a09e 100644
--- a/guix/scripts/perform-download.scm
+++ b/guix/scripts/perform-download.scm
@@ -114,10 +114,13 @@ (define* (perform-git-download drv output
;; on ambient authority, hence the PATH value below.
(setenv "PATH" "/run/current-system/profile/bin:/bin:/usr/bin")
+ ;; Note: When doing a '--check' build, DRV-OUTPUT and OUTPUT are
+ ;; different, hence the #:item argument below.
(git-fetch-with-fallback url commit output
#:hash hash
#:hash-algorithm algo
#:recursive? recursive?
+ #:item (derivation-output-path drv-output)
#:git-command %git))))
(define (assert-low-privileges)
--
2.41.0
L
L
Ludovic Courtès wrote on 23 Feb 16:48 +0100
[PATCH 10/12] download-nar: Distinguish ‘ou tput’ and ‘item’ parameter.
(address . 69328@debbugs.gnu.org)(name . Ludovic Courtès)(address . ludo@gnu.org)
abdf2085638ae0a8798aa5b1d20c359ed9dec106.1708697539.git.ludo@gnu.org
This is useful when running a ‘--check’ build, where the output file
name differs from the store file name we are trying to restore.

* guix/build/download-nar.scm (download-nar): Add ‘output’ parameter and
distinguish it from ‘item’.

Change-Id: I42219b6d4c8fd1ed506720301384efc1aa351561
---
guix/build/download-nar.scm | 12 ++++++------
1 file changed, 6 insertions(+), 6 deletions(-)

Toggle diff (39 lines)
diff --git a/guix/build/download-nar.scm b/guix/build/download-nar.scm
index 3ba121b7fb..f26ad28cd0 100644
--- a/guix/build/download-nar.scm
+++ b/guix/build/download-nar.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2017, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2017, 2019, 2020, 2024 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -57,9 +57,9 @@ (define (restore-lzipped-nar port item size)
(restore-file decompressed-port
item))))
-(define (download-nar item)
- "Download and extract the normalized archive for ITEM. Return #t on
-success, #f otherwise."
+(define* (download-nar item #:optional (output item))
+ "Download and extract to OUTPUT the normalized archive for ITEM, a store
+item. Return #t on success, #f otherwise."
;; Let progress reports go through.
(setvbuf (current-error-port) 'none)
(setvbuf (current-output-port) 'none)
@@ -96,10 +96,10 @@ (define (download-nar item)
#:download-size size)))
(if (string-contains url "/lzip")
(restore-lzipped-nar port-with-progress
- item
+ output
size)
(restore-file port-with-progress
- item)))
+ output)))
(newline)
#t))))
(()
--
2.41.0
L
L
Ludovic Courtès wrote on 23 Feb 16:48 +0100
[PATCH 12/12] download: Honor ‘GUIX_DOWNL OAD_SEQUENCE’ environment variable.
(address . 69328@debbugs.gnu.org)(name . Ludovic Courtès)(address . ludo@gnu.org)
0eafb9b6a14808552c10a4d9d44eef1ec69897f9.1708697539.git.ludo@gnu.org
This replaces ‘GUIX_DOWNLOAD_FALLBACK_TEST’ and allows you to test
various download methods, like so:

GUIX_DOWNLOAD_SEQUENCE=nar guix build guile-gcrypt -S --check
GUIX_DOWNLOAD_SEQUENCE=disarchive guix build hello -S --check

* guix/build/download.scm (%download-sequence): New variable.
(download-method-enabled?): New procedure.
(url-fetch): Define ‘initial-uris’; honor ‘download-method-enabled?’.
Call ‘disarchive-fetch/any’ only when the 'disarchive method is enabled.
* guix/build/git.scm (git-fetch-with-fallback): Honor
‘download-method-enabled?’.
* guix/download.scm (%download-sequence): New variable.
(%download-fallback-test): Remove.
(built-in-download): Add #:download-sequence parameter and honor it.
(url-fetch*): Pass #:content-addressed-mirrors and #:disarchive-mirrors
unconditionally.
* guix/git-download.scm (git-fetch/in-band*): Pass “git url”
unconditionally.
(git-fetch/built-in): Likewise. Pass “download-sequence”.
* guix/bzr-download.scm (bzr-fetch)[build]: Honor ‘download-method-enabled?’.
Pass ‘GUIX_DOWNLOAD_SEQUENCE’ to #:env-vars.
* guix/cvs-download.scm (cvs-fetch)[build]: Honor ‘download-method-enabled?’.
Pass ‘GUIX_DOWNLOAD_SEQUENCE’ to #:env-vars.
* guix/hg-download.scm (hg-fetch): Honor ‘download-method-enabled?’.
Pass #:env-vars to ‘gexp->derivation’.
* guix/scripts/perform-download.scm (perform-download): Honor
“download-sequence” from DRV. Parameterize ‘%download-sequence’ before
calling ‘url-fetch’.
(perform-git-download): Likewise.
* guix/svn-download.scm (svn-fetch): Honor ‘download-method-enabled?’.
Pass ‘GUIX_DOWNLOAD_SEQUENCE’ to #:env-vars.
(svn-multi-fetch): Likewise.

Change-Id: Ia3402e17f0303dfa964bdc761265efe8a1dd69ab
---
guix/build/download.scm | 50 ++++++++++++++-----
guix/build/git.scm | 15 ++++--
guix/bzr-download.scm | 28 +++++++----
guix/cvs-download.scm | 24 +++++++---
guix/download.scm | 53 ++++++++------------
guix/git-download.scm | 20 ++++----
guix/hg-download.scm | 36 +++++++++-----
guix/scripts/perform-download.scm | 68 ++++++++++++++------------
guix/svn-download.scm | 80 +++++++++++++++++++------------
9 files changed, 224 insertions(+), 150 deletions(-)

Toggle diff (385 lines)
diff --git a/guix/build/download.scm b/guix/build/download.scm
index db0a39084b..4155a66c1c 100644
--- a/guix/build/download.scm
+++ b/guix/build/download.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012-2022 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012-2022, 2024 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2015 Mark H Weaver <mhw@netris.org>
;;; Copyright © 2017 Tobias Geerinckx-Rice <me@tobias.gr>
;;; Copyright © 2021 Timothy Sample <samplet@ngyro.com>
@@ -40,7 +40,10 @@ (define-module (guix build download)
#:autoload (guix swh) (swh-download-directory %verify-swh-certificate?)
#:use-module (ice-9 match)
#:use-module (ice-9 format)
- #:export (open-socket-for-uri
+ #:export (%download-sequence
+ download-method-enabled?
+
+ open-socket-for-uri
open-connection-for-uri
http-fetch
%x509-certificate-directory
@@ -622,6 +625,20 @@ (define-syntax-rule (false-if-exception* body ...)
(lambda (key . args)
(print-exception (current-error-port) #f key args))))
+(define %download-sequence
+ ;; Either #f (the default) or a list of symbols denoting the sequence of
+ ;; download methods to be used--e.g., '(swh nar upstream).
+ (make-parameter
+ (and=> (getenv "GUIX_DOWNLOAD_SEQUENCE")
+ (lambda (str)
+ (map string->symbol (string-tokenize str))))))
+
+(define (download-method-enabled? method)
+ "Return true if METHOD (a symbol such as 'swh) is enabled as part of the
+download fallback sequence."
+ (or (not (%download-sequence))
+ (memq method (%download-sequence))))
+
(define (uri-vicinity dir file)
"Concatenate DIR, slash, and FILE, keeping only one slash in between.
This is required by some HTTP servers."
@@ -788,18 +805,28 @@ (define* (url-fetch url file
hashes)))
disarchive-mirrors))
+ (define initial-uris
+ (append (if (download-method-enabled? 'upstream)
+ uri
+ '())
+ (if (download-method-enabled? 'content-addressed-mirrors)
+ content-addressed-uris
+ '())
+ (if (download-method-enabled? 'internet-archive)
+ (match uri
+ ((first . _)
+ (or (and=> (internet-archive-uri first) list)
+ '()))
+ (() '()))
+ '())))
+
;; Make this unbuffered so 'progress-report/file' works as expected. 'line
;; means '\n', not '\r', so it's not appropriate here.
(setvbuf (current-output-port) 'none)
(setvbuf (current-error-port) 'line)
- (let try ((uri (append uri content-addressed-uris
- (match uri
- ((first . _)
- (or (and=> (internet-archive-uri first) list)
- '()))
- (() '())))))
+ (let try ((uri initial-uris))
(match uri
((uri tail ...)
(or (fetch uri file)
@@ -807,9 +834,10 @@ (define* (url-fetch url file
(()
;; If we are looking for a software archive, one last thing we
;; can try is to use Disarchive to assemble it.
- (or (disarchive-fetch/any disarchive-uris file
- #:verify-certificate? verify-certificate?
- #:timeout timeout)
+ (or (and (download-method-enabled? 'disarchive)
+ (disarchive-fetch/any disarchive-uris file
+ #:verify-certificate? verify-certificate?
+ #:timeout timeout))
(begin
(format (current-error-port) "failed to download ~s from ~s~%"
file url)
diff --git a/guix/build/git.scm b/guix/build/git.scm
index a135026fae..62877394bb 100644
--- a/guix/build/git.scm
+++ b/guix/build/git.scm
@@ -19,6 +19,8 @@
(define-module (guix build git)
#:use-module (guix build utils)
+ #:use-module ((guix build download)
+ #:select (download-method-enabled?))
#:autoload (guix build download-nar) (download-nar)
#:autoload (guix swh) (%verify-swh-certificate?
swh-download
@@ -102,17 +104,20 @@ (define* (git-fetch-with-fallback url commit directory
When HASH and HASH-ALGORITHM are provided, they are interpreted as the nar
hash of the directory of interested and are used as its content address at
SWH."
- (or (git-fetch url commit directory
- #:lfs? lfs?
- #:recursive? recursive?
- #:git-command git-command)
- (download-nar item directory)
+ (or (and (download-method-enabled? 'upstream)
+ (git-fetch url commit directory
+ #:lfs? lfs?
+ #:recursive? recursive?
+ #:git-command git-command))
+ (and (download-method-enabled? 'nar)
+ (download-nar item directory))
;; As a last resort, attempt to download from Software Heritage.
;; Disable X.509 certificate verification to avoid depending
;; on nss-certs--we're authenticating the checkout anyway.
;; XXX: Currently recursive checkouts are not supported.
(and (not recursive?)
+ (download-method-enabled? 'swh)
(parameterize ((%verify-swh-certificate? #f))
(format (current-error-port)
"Trying to download from Software Heritage...~%")
diff --git a/guix/bzr-download.scm b/guix/bzr-download.scm
index 01c12fd54d..ae8ab8d50e 100644
--- a/guix/bzr-download.scm
+++ b/guix/bzr-download.scm
@@ -24,7 +24,7 @@ (define-module (guix bzr-download)
#:use-module (guix packages)
#:use-module (guix records)
#:use-module (guix store)
-
+ #:use-module (ice-9 match)
#:export (bzr-reference
bzr-reference?
bzr-reference-url
@@ -72,20 +72,26 @@ (define* (bzr-fetch ref hash-algo hash
(with-imported-modules (source-module-closure
'((guix build bzr)
(guix build utils)
+ (guix build download)
(guix build download-nar)))
#~(begin
(use-modules (guix build bzr)
(guix build download-nar)
+ ((guix build download)
+ #:select (download-method-enabled?))
(guix build utils)
(srfi srfi-34))
- (or (guard (c ((invoke-error? c)
- (report-invoke-error c)
- #f))
- (bzr-fetch (getenv "bzr url") (getenv "bzr reference")
- #$output
- #:bzr-command (string-append #+bzr "/bin/brz")))
- (download-nar #$output))))))
+ (or (and (download-method-enabled? 'upstream)
+ (guard (c ((invoke-error? c)
+ (report-invoke-error c)
+ #f))
+ (bzr-fetch (getenv "bzr url") (getenv "bzr reference")
+ #$output
+ #:bzr-command
+ (string-append #+bzr "/bin/brz"))))
+ (and (download-method-enabled? 'nar)
+ (download-nar #$output)))))))
(mlet %store-monad ((guile (package->derivation guile system)))
(gexp->derivation (or name "bzr-branch") build
@@ -95,7 +101,11 @@ (define* (bzr-fetch ref hash-algo hash
#:script-name "bzr-download"
#:env-vars
`(("bzr url" . ,(bzr-reference-url ref))
- ("bzr reference" . ,(bzr-reference-revision ref)))
+ ("bzr reference" . ,(bzr-reference-revision ref))
+ ,@(match (getenv "GUIX_DOWNLOAD_SEQUENCE")
+ (#f '())
+ (value
+ `(("GUIX_DOWNLOAD_SEQUENCE" . ,value)))))
#:leaked-env-vars '("http_proxy" "https_proxy"
"LC_ALL" "LC_MESSAGES" "LANG"
"COLUMNS")
diff --git a/guix/cvs-download.scm b/guix/cvs-download.scm
index c0c526b9db..356c4e9cef 100644
--- a/guix/cvs-download.scm
+++ b/guix/cvs-download.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2014, 2015, 2016, 2017, 2019 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2014-2017, 2019, 2024 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2014 Sree Harsha Totakura <sreeharsha@totakura.in>
;;; Copyright © 2015 Mark H Weaver <mhw@netris.org>
;;;
@@ -73,6 +73,7 @@ (define* (cvs-fetch ref hash-algo hash
(define modules
(delete '(guix config)
(source-module-closure '((guix build cvs)
+ (guix build download)
(guix build download-nar)))))
(define build
(with-imported-modules modules
@@ -80,20 +81,29 @@ (define* (cvs-fetch ref hash-algo hash
guile-lzlib)
#~(begin
(use-modules (guix build cvs)
+ ((guix build download)
+ #:select (download-method-enabled?))
(guix build download-nar))
- (or (cvs-fetch '#$(cvs-reference-root-directory ref)
- '#$(cvs-reference-module ref)
- '#$(cvs-reference-revision ref)
- #$output
- #:cvs-command (string-append #+cvs "/bin/cvs"))
- (download-nar #$output))))))
+ (or (and (download-method-enabled? 'upstream)
+ (cvs-fetch '#$(cvs-reference-root-directory ref)
+ '#$(cvs-reference-module ref)
+ '#$(cvs-reference-revision ref)
+ #$output
+ #:cvs-command
+ #+(file-append cvs "/bin/cvs")))
+ (and (download-method-enabled? 'nar)
+ (download-nar #$output)))))))
(mlet %store-monad ((guile (package->derivation guile system)))
(gexp->derivation (or name "cvs-checkout") build
#:leaked-env-vars '("http_proxy" "https_proxy"
"LC_ALL" "LC_MESSAGES" "LANG"
"COLUMNS")
+ #:env-vars (match (getenv "GUIX_DOWNLOAD_SEQUENCE")
+ (#f '())
+ (value
+ `(("GUIX_DOWNLOAD_SEQUENCE" . ,value))))
#:system system
#:hash-algo hash-algo
#:hash hash
diff --git a/guix/download.scm b/guix/download.scm
index 21d02ab203..38621a4803 100644
--- a/guix/download.scm
+++ b/guix/download.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012-2021, 2024 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2013, 2014, 2015 Andreas Enge <andreas@enge.fr>
;;; Copyright © 2015 Federico Beffa <beffa@fbengineering.ch>
;;; Copyright © 2016 Alex Griffin <a@ajgrf.com>
@@ -35,9 +35,9 @@ (define-module (guix download)
#:use-module (web uri)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-26)
- #:export (%mirrors
+ #:export (%download-sequence
+ %mirrors
%disarchive-mirrors
- %download-fallback-test
(url-fetch* . url-fetch)
url-fetch/executable
url-fetch/tarbomb
@@ -434,10 +434,19 @@ (define %no-disarchive-mirrors-file
(define built-in-builders*
(store-lift built-in-builders))
+(define %download-sequence
+ ;; Either #f (the default) or a list of symbols denoting the sequence of
+ ;; download methods to be used--e.g., '(swh nar upstream).
+ (make-parameter
+ (and=> (getenv "GUIX_DOWNLOAD_SEQUENCE")
+ (lambda (str)
+ (map string->symbol (string-tokenize str))))))
+
(define* (built-in-download file-name url
#:key system hash-algo hash
mirrors content-addressed-mirrors
disarchive-mirrors
+ (download-sequence (%download-sequence))
executable?
(guile 'unused))
"Download FILE-NAME from URL using the built-in 'download' builder. When
@@ -471,6 +480,11 @@ (define* (built-in-download file-name url
("disarchive-mirrors" . ,disarchive-mirrors)
,@(if executable?
'(("executable" . "1"))
+ '())
+ ,@(if download-sequence
+ `(("download-sequence"
+ . ,(object->string
+ download-sequence)))
'()))
;; Do not offload this derivation because we cannot be
@@ -479,24 +493,6 @@ (define* (built-in-download file-name url
;; for that built-in is widespread.
#:local-build? #t)))
-(define %download-fallback-test
- ;; Define whether to test one of the download fallback mechanism. Possible
- ;; values are:
- ;;
- ;; - #f, to use the normal download methods, not trying to exercise the
- ;; fallback mechanism;
- ;;
- ;; - 'none, to disable all the fallback mechanisms;
- ;;
- ;; - 'content-addressed-mirrors, to purposefully attempt to download from
- ;; a content-addressed mirror;
- ;;
- ;; - 'disarchive-mirrors, to download from Disarchive + Software Heritage.
- ;;
- ;; This is meant to be used for testing purposes.
- (make-parameter (and=> (getenv "GUIX_DOWNLOAD_FALLBACK_TEST")
- string->symbol)))
-
(define* (url-fetch* url hash-algo hash
#:optional name
#:key (system (%current-system))
@@ -532,10 +528,7 @@ (define* (url-fetch* url hash-algo hash
(unless (member "download" builtins)
(error "'guix-daemon' is too old, please upgrade" builtins))
- (built-in-download (or name file-name)
- (match (%download-fallback-test)
- ((or #f 'none) url)
- (_ "https://example.org/does-not-exist"))
+ (built-in-download (or name file-name) url
#:guile guile
#:system system
#:hash-algo hash-algo
@@ -543,15 +536,9 @@ (define* (url-fetch* url hash-algo hash
#:executable? executable?
#:mirrors %mirror-file
#:content-addressed-mirrors
- (match (%download-fallback-test)
- ((or #f 'content-addressed-mirrors)
- %content-addressed-mirror-file)
- (_ %no-mirrors-file))
+ %content-addressed-mirror-file
#:disarchive-mirrors
- (match (%download-fallback-test)
- ((or #f 'disarchive-mirrors)
- %disarchive-mirror-file)
- (_ %no-disarchive-mirrors-file)))))))
+ %disarchive-mirror-file)))))
(define* (url-fetch/executable url hash-algo hash
#:optional name
diff --git a/guix/git-download.scm b/guix/git-download.scm
index aadcbd234c..6f82712999 100644
--- a/guix/git-download.scm
+++ b/guix/git-download.scm
@@ -29,8 +29,8 @@ (define-module (guix git-download)
#:use-module (guix packages)
#:use-module (guix modules)
#:use-module ((guix derivations) #:select (raw-derivation))
+ #:autoload (guix download) (%download-sequence)
#:autoload (guix build-system gnu) (standard-packages)
- #:autoload (guix download) (%download-fallback-test)
#:autoload (git bindings) (libgit2-init!)
#:autoload (git repository) (repository-open
repository-close!
@@ -180,11 +180,7 @@ (define* (git-fetch/in-band* ref hash-algo hash
;; downloads.
#:script-name "git-download"
#:env-vars
- `(("git url" . ,(match (%download-fallback-test)
- ('content-addressed-mirrors
- "https://example.org/does-not-exist")
- (_
- (git-reference-url ref))))
+ `(("git url" . ,(git-reference-url ref))
("git commit" . ,(git-reference-commit ref))
("git recursive?" . ,(object->string
(git-reference-recursive? ref)))
@@ -246,14 +242,14 @@ (define* (git-fetch/built-in ref hash-alg
This message was truncated. Download the full message here.
L
L
Ludovic Courtès wrote on 23 Feb 16:48 +0100
[PATCH 08/12] svn-download: Use ‘swh-downlo ad-directory-by-nar-hash’.
(address . 69328@debbugs.gnu.org)(name . Ludovic Courtès)(address . ludo@gnu.org)
39b18f26579e05e76613f0be62dd4d70860b4876.1708697539.git.ludo@gnu.org

* guix/svn-download.scm (svn-fetch)[build]: Add
‘swh-download-directory-by-nar-hash’ call as a last resort.
Import (guix swh).
* guix/svn-download.scm (svn-multi-fetch)[build]: Likewise.

Change-Id: Ifcb9be1e9c2b05ce172c44e45dcf3a3ea6df8e76
---
guix/svn-download.scm | 20 +++++++++++++++-----
1 file changed, 15 insertions(+), 5 deletions(-)

Toggle diff (70 lines)
diff --git a/guix/svn-download.scm b/guix/svn-download.scm
index c6688908de..ed1379a09e 100644
--- a/guix/svn-download.scm
+++ b/guix/svn-download.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2014-2016, 2019, 2021-2023 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2014-2016, 2019, 2021-2024 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2014 Sree Harsha Totakura <sreeharsha@totakura.in>
;;; Copyright © 2017, 2019, 2021 Ricardo Wurmus <rekado@elephly.net>
;;;
@@ -94,12 +94,14 @@ (define* (svn-fetch ref hash-algo hash
(with-imported-modules
(source-module-closure '((guix build svn)
(guix build download-nar)
- (guix build utils)))
+ (guix build utils)
+ (guix swh)))
(with-extensions (list guile-json guile-gnutls ;for (guix swh)
guile-lzlib)
#~(begin
(use-modules (guix build svn)
(guix build download-nar)
+ (guix swh)
(ice-9 match))
(or (svn-fetch (getenv "svn url")
@@ -111,7 +113,10 @@ (define* (svn-fetch ref hash-algo hash
(_ #f))
#:user-name (getenv "svn user name")
#:password (getenv "svn password"))
- (download-nar #$output))))))
+ (download-nar #$output)
+ (parameterize ((%verify-swh-certificate? #f))
+ (swh-download-directory-by-nar-hash #$hash '#$hash-algo
+ #$output)))))))
(mlet %store-monad ((guile (package->derivation guile system)))
(gexp->derivation (or name "svn-checkout") build
@@ -174,13 +179,15 @@ (define* (svn-multi-fetch ref hash-algo hash
(with-imported-modules
(source-module-closure '((guix build svn)
(guix build download-nar)
- (guix build utils)))
+ (guix build utils)
+ (guix swh)))
(with-extensions (list guile-json guile-gnutls ;for (guix swh)
guile-lzlib)
#~(begin
(use-modules (guix build svn)
(guix build utils)
(guix build download-nar)
+ (guix swh)
(srfi srfi-1)
(ice-9 match))
@@ -206,7 +213,10 @@ (define* (svn-multi-fetch ref hash-algo hash
(begin
(when (file-exists? #$output)
(delete-file-recursively #$output))
- (download-nar #$output)))))))
+ (or (download-nar #$output)
+ (parameterize ((%verify-swh-certificate? #f))
+ (swh-download-directory-by-nar-hash
+ #$hash '#$hash-algo #$output)))))))))
(mlet %store-monad ((guile (package->derivation guile system)))
(gexp->derivation (or name "svn-checkout") build
--
2.41.0
L
L
Ludovic Courtès wrote on 23 Feb 16:48 +0100
[PATCH 07/12] hg-download: Use ‘swh-downloa d-directory-by-nar-hash’.
(address . 69328@debbugs.gnu.org)(name . Ludovic Courtès)(address . ludo@gnu.org)
23d5acc774d3b0cff08026cad1a025248c6cc80b.1708697539.git.ludo@gnu.org
This allows content-addressed access to the checkout, which is
preferable.

* guix/hg-download.scm (hg-fetch): Add call to
‘swh-download-directory-by-nar-hash’ before ‘swh-download’ call.

Change-Id: I2afc8badc1f8bb2c8bdd3a47abbb72d455d93e64
---
guix/hg-download.scm | 10 ++++++----
1 file changed, 6 insertions(+), 4 deletions(-)

Toggle diff (28 lines)
diff --git a/guix/hg-download.scm b/guix/hg-download.scm
index 6d02de47e4..dd28d9c244 100644
--- a/guix/hg-download.scm
+++ b/guix/hg-download.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2014, 2015, 2016, 2017, 2019 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2014-2017, 2019, 2024 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2016 Ricardo Wurmus <rekado@elephly.net>
;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz>
;;;
@@ -117,9 +117,11 @@ (define* (hg-fetch ref hash-algo hash
(parameterize ((%verify-swh-certificate? #f))
(format (current-error-port)
"Trying to download from Software Heritage...~%")
- (swh-download #$(hg-reference-url ref)
- #$(hg-reference-changeset ref)
- #$output)))))))
+ (or (swh-download-directory-by-nar-hash #$hash '#$hash-algo
+ #$output)
+ (swh-download #$(hg-reference-url ref)
+ #$(hg-reference-changeset ref)
+ #$output))))))))
(mlet %store-monad ((guile (package->derivation guile system)))
(gexp->derivation (or name "hg-checkout") build
--
2.41.0
L
L
Ludovic Courtès wrote on 23 Feb 16:48 +0100
[PATCH 03/12] lint: archival: Trigger “Sa ve Code Now” for VCSes other than Git.
(address . 69328@debbugs.gnu.org)(name . Ludovic Courtès)(address . ludovic.courtes@inria.fr)
38211161ee2bf6fbaab40362ebd654dc1cbad986.1708697539.git.ludo@gnu.org
From: Ludovic Courtès <ludovic.courtes@inria.fr>

Until now, ‘save-origin’ would be called only when given a
<git-reference>. With this change, ‘save-origin’ gets called for other
version control systems as well.

* guix/lint.scm (swh-response->warning): New procedure, formerly in
‘check-archival’.
(vcs-origin, save-package-source): New procedures.
(check-archival)[response->warning]: Remove.
Call ‘save-package-source’ in both the Git and the non-Git cases.
* tests/lint.scm ("archival: missing svn revision"): New test.

Change-Id: I535e4ec89488faf83bfa544d5e4935fa73ef54fb
---
guix/lint.scm | 140 +++++++++++++++++++++++++++++++------------------
tests/lint.scm | 20 +++++++
2 files changed, 109 insertions(+), 51 deletions(-)

Toggle diff (222 lines)
diff --git a/guix/lint.scm b/guix/lint.scm
index ad84048660..68d532968d 100644
--- a/guix/lint.scm
+++ b/guix/lint.scm
@@ -67,6 +67,10 @@ (define-module (guix lint)
svn-multi-reference-url
svn-multi-reference-user-name
svn-multi-reference-password)
+ #:autoload (guix hg-download) (hg-reference?
+ hg-reference-url)
+ #:autoload (guix bzr-download) (bzr-reference?
+ bzr-reference-url)
#:use-module (guix import stackage)
#:use-module (ice-9 match)
#:use-module (ice-9 regex)
@@ -1632,6 +1636,69 @@ (define (lookup-disarchive-spec hash)
(extract-swh-id spec)))))
%disarchive-mirrors))
+(define (swh-response->warning package url method response)
+ "Given RESPONSE, the response of METHOD on URL, return a suitable warning
+list for PACKAGE."
+ (if (request-rate-limit-reached? url method)
+ (list (make-warning package
+ (G_ "Software Heritage rate limit reached; \
+try again later")
+ #:field 'source))
+ (list (make-warning package
+ (G_ "'~a' returned ~a")
+ (list url (response-code response))
+ #:field 'source))))
+
+(define (vcs-origin origin)
+ "Return two values: the URL and type (a string) of the version-control used
+for ORIGIN. Return #f and #f if ORIGIN is not a version-control checkout."
+ (match (and=> origin origin-uri)
+ ((? git-reference? ref)
+ (values (git-reference-url ref) "git"))
+ ((? svn-reference? ref)
+ (values (svn-reference-url ref) "svn"))
+ ((? svn-multi-reference? ref)
+ (values (svn-multi-reference-url ref) "svn"))
+ ((? hg-reference? ref)
+ (values (hg-reference-url ref) "hg"))
+ ((? bzr-reference? ref)
+ (values (bzr-reference-url ref) "bzr"))
+ ;; XXX: Not sure what to do with the weird CVS URIs (:pserver: etc.).
+ (_
+ (values #f #f))))
+
+(define (save-package-source package)
+ "Attempt to save the source of PACKAGE on SWH. Return a list of warnings."
+ (let* ((origin (package-source package))
+ (url type (if origin (vcs-origin origin) (values #f #f))))
+ (cond ((and url type)
+ (catch 'swh-error
+ (lambda ()
+ (save-origin url type)
+ (list (make-warning
+ package
+ ;; TRANSLATORS: "Software Heritage" is a proper noun that
+ ;; must remain untranslated. See
+ ;; <https://www.softwareheritage.org>.
+ (G_ "scheduled Software Heritage archival")
+ #:field 'source)))
+ (lambda (key url method response . _)
+ (cond ((= 429 (response-code response))
+ (list (make-warning
+ package
+ (G_ "archival rate limit exceeded; \
+try again later")
+ #:field 'source)))
+ (else
+ (swh-response->warning package url method response))))))
+ ((not origin)
+ '())
+ (else
+ (list (make-warning
+ package
+ (G_ "source code cannot be archived")
+ #:field 'source))))))
+
(define (check-archival package)
"Check whether PACKAGE's source code is archived on Software Heritage. If
it's not, and if its source code is a VCS snapshot, then send a \"save\"
@@ -1640,17 +1707,6 @@ (define (check-archival package)
Software Heritage imposes limits on the request rate per client IP address.
This checker prints a notice and stops doing anything once that limit has been
reached."
- (define (response->warning url method response)
- (if (request-rate-limit-reached? url method)
- (list (make-warning package
- (G_ "Software Heritage rate limit reached; \
-try again later")
- #:field 'source))
- (list (make-warning package
- (G_ "'~a' returned ~a")
- (list url (response-code response))
- #:field 'source))))
-
(define skip-key (gensym "skip-archival-check"))
(define (skip-when-limit-reached url method)
@@ -1685,28 +1741,8 @@ (define (check-archival package)
'())
(#f
;; Revision is missing from the archive, attempt to save it.
- (catch 'swh-error
- (lambda ()
- (save-origin (git-reference-url reference) "git")
- (list (make-warning
- package
- ;; TRANSLATORS: "Software Heritage" is a proper noun
- ;; that must remain untranslated. See
- ;; <https://www.softwareheritage.org>.
- (G_ "scheduled Software Heritage archival")
- #:field 'source)))
- (lambda (key url method response . _)
- (cond ((= 429 (response-code response))
- (list (make-warning
- package
- (G_ "archival rate limit exceeded; \
-try again later")
- #:field 'source)))
- (else
- (response->warning url method response))))))))
+ (save-package-source package))))
((? origin? origin)
- ;; Since "save" origins are not supported for non-VCS source, all
- ;; we can do is tell whether a given tarball is available or not.
(if (and=> (origin-hash origin) ;XXX: for ungoogled-chromium
content-hash-value) ;& icecat
(let ((hash (origin-hash origin)))
@@ -1715,26 +1751,28 @@ (define (check-archival package)
(symbol->string
(content-hash-algorithm hash))))
(#f
- ;; If SWH doesn't have HASH as is, it may be because it's
- ;; a hand-crafted tarball. In that case, check whether
- ;; the Disarchive database has an entry for that tarball.
- (match (lookup-disarchive-spec hash)
- (#f
- (list (make-warning package
- (G_ "source not archived on Software \
+ ;; If ORIGIN is a version-control checkout, save it now.
+ ;; If not, check whether HASH is in the Disarchive
+ ;; database ("Save Code Now" does not accept tarballs).
+ (if (vcs-origin origin)
+ (save-package-source package)
+ (match (lookup-disarchive-spec hash)
+ (#f
+ (list (make-warning package
+ (G_ "source not archived on Software \
Heritage and missing from the Disarchive database")
- #:field 'source)))
- (directory-ids
- (match (find (lambda (id)
- (not (lookup-directory id)))
- directory-ids)
- (#f '())
- (id
- (list (make-warning package
- (G_ "\
+ #:field 'source)))
+ (directory-ids
+ (match (find (lambda (id)
+ (not (lookup-directory id)))
+ directory-ids)
+ (#f '())
+ (id
+ (list (make-warning package
+ (G_ "\
Disarchive entry refers to non-existent SWH directory '~a'")
- (list id)
- #:field 'source)))))))
+ (list id)
+ #:field 'source))))))))
((? content?)
'())
((? string? swhid)
@@ -1749,7 +1787,7 @@ (define (check-archival package)
#:field 'source)))))
(match-lambda*
(('swh-error url method response)
- (response->warning url method response))
+ (swh-response->warning package url method response))
((key . args)
(if (eq? key skip-key)
'()
diff --git a/tests/lint.scm b/tests/lint.scm
index 87213fcc78..95d82d7490 100644
--- a/tests/lint.scm
+++ b/tests/lint.scm
@@ -1407,6 +1407,26 @@ (define (package-with-phase-changes changes)
(check-archival (dummy-package "x" (source origin)))))))
(warning-contains? "scheduled" warnings)))
+(test-assert "archival: missing svn revision"
+ (let* ((origin (origin
+ (method svn-fetch)
+ (uri (svn-reference
+ (url "http://example.org/svn/foo")
+ (revision "1234")))
+ (sha256 (make-bytevector 32))))
+ ;; https://archive.softwareheritage.org/api/1/origin/save/
+ (save "{ \"origin_url\": \"http://example.org/svn/foo\",
+ \"save_request_date\": \"2014-11-17T22:09:38+01:00\",
+ \"save_request_status\": \"accepted\",
+ \"save_task_status\": \"scheduled\" }")
+ (warnings (with-http-server `((404 "No extid.") ;lookup-directory-by-nar-hash
+ (404 "No revision.") ;lookup-revision
+ (404 "No origin.") ;lookup-origin
+ (200 ,save)) ;save-origin
+ (parameterize ((%swh-base-url (%local-url)))
+ (check-archival (dummy-package "x" (source origin)))))))
+ (warning-contains? "scheduled" warnings)))
+
(test-equal "archival: revision available"
'()
(let* ((origin (origin
--
2.41.0
L
L
Ludovic Courtès wrote on 23 Feb 16:53 +0100
Re: [bug#69328] [PATCH 00/12] Better source code recovery from SWH
(address . 69328@debbugs.gnu.org)(name . Timothy Sample)(address . samplet@ngyro.com)
87bk87gort.fsf@gnu.org
I forgot to Cc: you Timothy, but you may have useful feedback to give on

(Should we create a ‘source-code-archival’ team?)
L
L
Ludovic Courtès wrote on 23 Feb 16:48 +0100
[PATCH 01/12] lint: Switch to SRFI-71.
(address . 69328@debbugs.gnu.org)(name . Ludovic Courtès)(address . ludo@gnu.org)
1b2244ba8d74755eac44e84b35f9867a8585784e.1708697539.git.ludo@gnu.org
* guix/lint.scm: Switch from SRFI-11 to SRFI-71.

Change-Id: I62e6cd304ad73570bd12bd67f7051566205596bb
---
guix/lint.scm | 9 ++++-----
1 file changed, 4 insertions(+), 5 deletions(-)

Toggle diff (39 lines)
diff --git a/guix/lint.scm b/guix/lint.scm
index c95de85e69..84df171045 100644
--- a/guix/lint.scm
+++ b/guix/lint.scm
@@ -84,10 +84,10 @@ (define-module (guix lint)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-6) ;Unicode string ports
#:use-module (srfi srfi-9)
- #:use-module (srfi srfi-11)
#:use-module (srfi srfi-26)
#:use-module (srfi srfi-34)
#:use-module (srfi srfi-35)
+ #:use-module (srfi srfi-71)
#:use-module (ice-9 rdelim)
#:export (check-description-style
check-inputs-should-be-native
@@ -823,8 +823,8 @@ (define* (probe-uri uri #:key timeout)
;; Return RESPONSE, unless the final response as we follow
;; redirects is not 200.
(if location
- (let-values (((status response2)
- (loop location (cons location visited))))
+ (let ((status response2 (loop location
+ (cons location visited))))
(case status
((http-response)
(values 'http-response
@@ -926,8 +926,7 @@ (define (tls-certificate-error-string args)
(define (validate-uri uri package field)
"Return #t if the given URI can be reached, otherwise return a warning for
PACKAGE mentioning the FIELD."
- (let-values (((status argument)
- (probe-uri uri #:timeout 3))) ;wait at most 3 seconds
+ (let ((status argument (probe-uri uri #:timeout 3))) ;wait at most 3 seconds
(case status
((http-response)
(cond ((= 200 (response-code argument))
--
2.41.0
L
L
Ludovic Courtès wrote on 23 Feb 16:48 +0100
[PATCH 02/12] lint: archival: Fix crash in non-Git case.
(address . 69328@debbugs.gnu.org)(name . Ludovic Courtès)(address . ludo@gnu.org)
0f673f19854b1b4bab62e08d6ec336c7200b5857.1708697539.git.ludo@gnu.org
Fixes a bug introduced in 29f3089c841f00144f24f5c32296aebf22d752cc where
‘guix lint -c archival guile-wisp’ (for instance) would crash with a
match error because ‘lookup-by-nar-hash’ returns a string.

* guix/lint.scm (check-archival): Add SWHID case in the non-Git case.

Change-Id: I66fb060172d372041df47d90a14df168b0fa762d
---
guix/lint.scm | 2 ++
1 file changed, 2 insertions(+)

Toggle diff (15 lines)
diff --git a/guix/lint.scm b/guix/lint.scm
index 84df171045..ad84048660 100644
--- a/guix/lint.scm
+++ b/guix/lint.scm
@@ -1736,6 +1736,8 @@ (define (check-archival package)
(list id)
#:field 'source)))))))
((? content?)
+ '())
+ ((? string? swhid)
'())))
'()))
((? local-file?)
--
2.41.0
L
L
Ludovic Courtès wrote on 23 Feb 16:48 +0100
[PATCH 04/12] swh: Add ‘type’ fie ld to <visit>.
(address . 69328@debbugs.gnu.org)(name . Ludovic Courtès)(address . ludo@gnu.org)
7c992a535832f71d9624741cedd5095d2bd3b4ba.1708697539.git.ludo@gnu.org
* guix/swh.scm (<visit>)[type]: New field.

Change-Id: I7677984c7daef38d8f3c3bef19723fa0efb035ba
---
guix/swh.scm | 2 ++
1 file changed, 2 insertions(+)

Toggle diff (22 lines)
diff --git a/guix/swh.scm b/guix/swh.scm
index 04cecd854c..83f67423c8 100644
--- a/guix/swh.scm
+++ b/guix/swh.scm
@@ -54,6 +54,7 @@ (define-module (guix swh)
visit-snapshot-url
visit-status
visit-number
+ visit-type
visit-snapshot
snapshot?
@@ -312,6 +313,7 @@ (define-json-mapping <visit> make-visit visit?
(url visit-url "origin_visit_url")
(snapshot-url visit-snapshot-url "snapshot_url" string*) ;string | #f
(status visit-status "status" string->symbol) ;'full | 'partial | 'ongoing
+ (type visit-type "type" string->symbol) ;'git | 'git-checkout | ...
(number visit-number "visit"))
;; <https://archive.softwareheritage.org/api/1/snapshot/4334c3ed4bb208604ed780d8687fe523837f1bd1/>
--
2.41.0
L
L
Ludovic Courtès wrote on 23 Feb 16:48 +0100
[PATCH 06/12] swh: ‘lookup-origin-revision ’ handles branches pointing to directories.
(address . 69328@debbugs.gnu.org)(name . Ludovic Courtès)(address . ludo@gnu.org)
59c8e6bb4f5aadd4a60c18b60665391a65b10b45.1708697539.git.ludo@gnu.org

* guix/swh.scm (branch-target): Add clause for 'directory and 'alias.
(lookup-origin-revision): Iterate over all the visits of ORIGIN instead
of just the first one. Handle the case where ‘branch-target’ returns
something other than a release or revision.
* tests/swh.scm ("lookup-origin-revision"): New test.

Change-Id: I7f636739a719908763bca1d3e7376341dd62e816
---
guix/swh.scm | 60 ++++++++++++++++++++++-------------------
tests/swh.scm | 74 +++++++++++++++++++++++++++++++++++++++++++++++++++
2 files changed, 107 insertions(+), 27 deletions(-)

Toggle diff (171 lines)
diff --git a/guix/swh.scm b/guix/swh.scm
index 14c65f6806..f602cd89d1 100644
--- a/guix/swh.scm
+++ b/guix/swh.scm
@@ -516,14 +516,20 @@ (define (lookup-snapshot-branch snapshot name)
(_ #f)))))
(define (branch-target branch)
- "Return the target of BRANCH, either a <revision> or a <release>."
+ "Return the target of BRANCH: a <revision>, a <release>, or the SWHID of a
+directory."
(match (branch-target-type branch)
('release
(call (swh-url (branch-target-url branch))
json->release))
('revision
(call (swh-url (branch-target-url branch))
- json->revision))))
+ json->revision))
+ ((or 'directory 'alias)
+ (match (string-tokenize (branch-target-url branch)
+ (char-set-complement (char-set #\/)))
+ ((_ ... "directory" id)
+ (string-append "swh:1:dir:" id))))))
(define (lookup-origin-revision url tag)
"Return a <revision> corresponding to the given TAG for the repository
@@ -537,31 +543,31 @@ (define (lookup-origin-revision url tag)
(match (lookup-origin url)
(#f #f)
(origin
- (match (filter (lambda (visit)
- ;; Return #f if (visit-snapshot VISIT) would return #f.
- (and (visit-snapshot-url visit)
- (eq? 'full (visit-status visit))))
- (origin-visits origin))
- ((visit . _)
- (let ((snapshot (visit-snapshot visit)))
- (match (and=> (find (lambda (branch)
- (or
- ;; Git specific.
- (string=? (string-append "refs/tags/" tag)
- (branch-name branch))
- ;; Hg specific.
- (string=? tag
- (branch-name branch))))
- (snapshot-branches snapshot))
- branch-target)
- ((? release? release)
- (release-target release))
- ((? revision? revision)
- revision)
- (#f ;tag not found
- #f))))
- (()
- #f)))))
+ (any (lambda (visit)
+ (and (visit-snapshot-url visit)
+ (eq? 'full (visit-status visit))
+ (let ((snapshot (visit-snapshot visit)))
+ (match (and=> (find (lambda (branch)
+ (or
+ ;; Git specific.
+ (string=? (string-append "refs/tags/" tag)
+ (branch-name branch))
+ ;; Hg specific.
+ (string=? tag
+ (branch-name branch))))
+ (snapshot-branches snapshot))
+ branch-target)
+ ((? release? release)
+ (release-target release))
+ ((? revision? revision)
+ revision)
+ (_
+ ;; Either the branch points to a directory rather than
+ ;; a revision (this is the case for visits of type
+ ;; 'git-checkout, 'hg-checkout, 'tarball-directory,
+ ;; etc.), or TAG was not found.
+ #f)))))
+ (origin-visits origin 30)))))
(define (release-target release)
"Return the revision that is the target of RELEASE."
diff --git a/tests/swh.scm b/tests/swh.scm
index e7ced6b50c..11dcbdddd8 100644
--- a/tests/swh.scm
+++ b/tests/swh.scm
@@ -109,6 +109,80 @@ (define-syntax-rule (with-json-result str exp ...)
(directory-entry-length entry)))
(lookup-directory "123"))))
+(test-equal "lookup-origin-revision"
+ '("cd86c72084993d9ef26fc9e24b73cea612b8c97b"
+ "d173c707ee88e3c89401ad77fafa65fcd9e9f5be")
+ (let ()
+ ;; Make sure that 'lookup-origin-revision' does the job, and in particular
+ ;; that it doesn't stop until it has found an actual revision:
+ ;; 'git-checkout visits point to directories instead of revisions.
+ ;; See <https://issues.guix.gnu.org/69070>.
+ (define visits
+ ;; Two visits of differing types: the first visit (type 'git-checkout')
+ ;; points to a directory, the second one (type 'git') points to a
+ ;; revision.
+ "[ {
+ \"origin\": \"https://example.org/repo.git\",
+ \"visit\": 1,
+ \"type\": \"git-checkout\",
+ \"date\": \"2020-05-17T21:43:45.422977+00:00\",
+ \"status\": \"full\",
+ \"metadata\": {},
+ \"type\": \"git-checkout\",
+ \"origin_visit_url\": \"/visit/42\",
+ \"snapshot_url\": \"/snapshot/1\"
+ }, {
+ \"origin\": \"https://example.org/repo.git\",
+ \"visit\": 2,
+ \"type\": \"git\",
+ \"date\": \"2020-05-17T21:43:49.422977+00:00\",
+ \"status\": \"full\",
+ \"metadata\": {},
+ \"type\": \"git\",
+ \"origin_visit_url\": \"/visit/41\",
+ \"snapshot_url\": \"/snapshot/2\"
+ } ]")
+ (define snapshot-for-git-checkout
+ "{ \"id\": 42,
+ \"branches\": { \"1.3.2\": {
+ \"target\": \"e4a4be18fae8d9c6528abff3bc9088feb19a76c7\",
+ \"target_type\": \"directory\",
+ \"target_url\": \"/directory/e4a4be18fae8d9c6528abff3bc9088feb19a76c7\"
+ }}
+ }")
+ (define snapshot-for-git
+ "{ \"id\": 42,
+ \"branches\": { \"1.3.2\": {
+ \"target\": \"e4a4be18fae8d9c6528abff3bc9088feb19a76c7\",
+ \"target_type\": \"revision\",
+ \"target_url\": \"/revision/e4a4be18fae8d9c6528abff3bc9088feb19a76c7\"
+ }}
+ }")
+ (define revision
+ "{ \"author\": {},
+ \"committer\": {},
+ \"committer_date\": \"2018-05-17T21:43:49.422977+00:00\",
+ \"date\": \"2018-05-17T21:43:49.422977+00:00\",
+ \"directory\": \"d173c707ee88e3c89401ad77fafa65fcd9e9f5be\",
+ \"directory_url\": \"/directory/d173c707ee88e3c89401ad77fafa65fcd9e9f5be\",
+ \"id\": \"cd86c72084993d9ef26fc9e24b73cea612b8c97b\",
+ \"merge\": false,
+ \"message\": \"Fix.\",
+ \"parents\": [],
+ \"type\": \"what type?\"
+ }")
+
+ (with-http-server `((200 ,%origin)
+ (200 ,visits)
+ (200 ,snapshot-for-git-checkout)
+ (200 ,snapshot-for-git)
+ (200 ,revision))
+ (parameterize ((%swh-base-url (%local-url)))
+ (let ((revision (lookup-origin-revision "https://example.org/repo.git"
+ "1.3.2")))
+ (list (revision-id revision)
+ (revision-directory revision)))))))
+
(test-equal "lookup-directory-by-nar-hash"
"swh:1:dir:84a8b34591712c0a90bab0af604188bcd1fe3153"
(with-json-result %external-id
--
2.41.0
T
T
Timothy Sample wrote on 3 Mar 05:53 +0100
Re: [bug#69328] [PATCH 12/12] download: Honor ‘GUIX_DOWNLOAD_SEQUENCE’ environment variable.
(name . Ludovic Courtès)(address . ludo@gnu.org)
87jzmjkjb2.fsf@ngyro.com
Ludovic Courtès <ludo@gnu.org> writes:

Toggle quote (27 lines)
> diff --git a/guix/scripts/perform-download.scm b/guix/scripts/perform-download.scm
> index b96959a09e..250b1c2b48 100644
> --- a/guix/scripts/perform-download.scm
> +++ b/guix/scripts/perform-download.scm
> @@ -114,14 +120,16 @@ (define* (perform-git-download drv output
> ;; on ambient authority, hence the PATH value below.
> (setenv "PATH" "/run/current-system/profile/bin:/bin:/usr/bin")
>
> - ;; Note: When doing a '--check' build, DRV-OUTPUT and OUTPUT are
> - ;; different, hence the #:item argument below.
> - (git-fetch-with-fallback url commit output
> - #:hash hash
> - #:hash-algorithm algo
> - #:recursive? recursive?
> - #:item (derivation-output-path drv-output)
> - #:git-command %git))))
> + (parameterize ((%download-sequence
> + (and download-sequence
> + (call-with-input-string download-sequence
> + read))))
> + (git-fetch-with-fallback url commit output
> + #:hash hash
> + #:hash-algorithm algo
> + #:recursive? recursive?
> + #:item (derivation-output-path drv-output)
> + #:git-command %git)))))

Did you mean to delete the comment here?
T
T
Timothy Sample wrote on 3 Mar 05:54 +0100
Re: [bug#69328] [PATCH 00/12] Better source code recovery from SWH
(name . Ludovic Courtès)(address . ludo@gnu.org)
87il23kj9d.fsf@ngyro.com
Ludovic Courtès <ludo@gnu.org> writes:

Toggle quote (20 lines)
> Hello Guix!
>
> This patch series improves source code recovery from SWH, as a followup
> to <https://issues.guix.gnu.org/68741>.
>
> It does several things:
>
> • ‘guix lint -c archival’ now emits save requests for VCSes other
> than Git.
>
> • Fix <https://issues.guix.gnu.org/69070>.
>
> • Allow content-addressed recovery of Mercurial and Subversion
> checkouts.
>
> • Allow Bazaar recovery using ‘download-nar’ (I didn’t bother with SWH).
>
> • Have all these things honor the ‘GUIX_DOWNLOAD_SEQUENCE’ environment
> variable.

Very nice! I like the design of ‘GUIX_DOWNLOAD_SEQUENCE’ compared to
‘GUIX_DOWNLOAD_FALLBACK_TEST’, but I’m not sure about the name (sorry
for bike shedding!). In particular, the “sequences” ‘(nar swh)’ and
‘(swh nar)’ will both try ‘nar’ first and then ‘swh’. What about
“methods” or “strategies” or something?

Toggle quote (6 lines)
> You can try the various methods like this:
>
> GUIX_DOWNLOAD_SEQUENCE=nar ./pre-inst-env guix build -S apl --check
> GUIX_DOWNLOAD_SEQUENCE=swh ./pre-inst-env guix build -S guile-wisp --check
> GUIX_DOWNLOAD_SEQUENCE=swh ./pre-inst-env guix build -S guile-gcrypt --check

I tried

GUIX_DOWNLOAD_SEQUENCE=disarchive ./pre-inst-env guix build -S mes --check

and it worked like a charm.

Toggle quote (2 lines)
> Feedback welcome!

Other than the name and the little separate comment on the last patch,
this all LGTM.


-- Tim
L
L
Ludovic Courtès wrote on 5 Mar 11:26 +0100
Re: [bug#69328] [PATCH 12/12] download: Honor ‘GUIX_DOWNLOAD_SEQUENCE’ environment variable.
(name . Timothy Sample)(address . samplet@ngyro.com)
87ttllc6v8.fsf@gnu.org
Timothy Sample <samplet@ngyro.com> skribis:

Toggle quote (31 lines)
> Ludovic Courtès <ludo@gnu.org> writes:
>
>> diff --git a/guix/scripts/perform-download.scm b/guix/scripts/perform-download.scm
>> index b96959a09e..250b1c2b48 100644
>> --- a/guix/scripts/perform-download.scm
>> +++ b/guix/scripts/perform-download.scm
>> @@ -114,14 +120,16 @@ (define* (perform-git-download drv output
>> ;; on ambient authority, hence the PATH value below.
>> (setenv "PATH" "/run/current-system/profile/bin:/bin:/usr/bin")
>>
>> - ;; Note: When doing a '--check' build, DRV-OUTPUT and OUTPUT are
>> - ;; different, hence the #:item argument below.
>> - (git-fetch-with-fallback url commit output
>> - #:hash hash
>> - #:hash-algorithm algo
>> - #:recursive? recursive?
>> - #:item (derivation-output-path drv-output)
>> - #:git-command %git))))
>> + (parameterize ((%download-sequence
>> + (and download-sequence
>> + (call-with-input-string download-sequence
>> + read))))
>> + (git-fetch-with-fallback url commit output
>> + #:hash hash
>> + #:hash-algorithm algo
>> + #:recursive? recursive?
>> + #:item (derivation-output-path drv-output)
>> + #:git-command %git)))))
>
> Did you mean to delete the comment here?

Nope, good catch!
L
L
Ludovic Courtès wrote on 5 Mar 11:58 +0100
Re: [bug#69328] [PATCH 00/12] Better source code recovery from SWH
(name . Timothy Sample)(address . samplet@ngyro.com)
87o7btc5du.fsf@gnu.org
Hi,

Timothy Sample <samplet@ngyro.com> skribis:

Toggle quote (2 lines)
> Ludovic Courtès <ludo@gnu.org> writes:

[...]

Toggle quote (9 lines)
>> • Have all these things honor the ‘GUIX_DOWNLOAD_SEQUENCE’ environment
>> variable.
>
> Very nice! I like the design of ‘GUIX_DOWNLOAD_SEQUENCE’ compared to
> ‘GUIX_DOWNLOAD_FALLBACK_TEST’, but I’m not sure about the name (sorry
> for bike shedding!). In particular, the “sequences” ‘(nar swh)’ and
> ‘(swh nar)’ will both try ‘nar’ first and then ‘swh’. What about
> “methods” or “strategies” or something?

Good point; I like “methods”.

Toggle quote (3 lines)
> Other than the name and the little separate comment on the last patch,
> this all LGTM.

Awesome; I’ll send an updated version and merge by the end of the week
if nobody objects.

Ludo’.
L
L
Ludovic Courtès wrote on 5 Mar 12:06 +0100
[PATCH v2 00/12] Better source code recovery from SWH
(address . 69328@debbugs.gnu.org)
cover.1709636144.git.ludo@gnu.org
Hello!

Changes since v1:

• Renamed ‘GUIX_DOWNLOAD_SEQUENCE’ to ‘GUIX_DOWNLOAD_METHODS’ as
suggested by Timothy.

• Reinstated comment that was inadvertently removed in last patch.

• Added comment in ‘svn-multi-fetch’ fallback pointing to SWH
issue being discussed.

I plan to push by the end of the week if there are no objections.

Ludo’.

Ludovic Courtès (12):
lint: Switch to SRFI-71.
lint: archival: Fix crash in non-Git case.
lint: archival: Trigger “Save Code Now” for VCSes other than Git.
swh: Add ‘type’ field to <visit>.
swh: ‘origin-visits’ takes an optional ‘max’ parameter.
swh: ‘lookup-origin-revision’ handles branches pointing to
directories.
hg-download: Use ‘swh-download-directory-by-nar-hash’.
svn-download: Use ‘swh-download-directory-by-nar-hash’.
bzr-download: Implement nar fallback.
download-nar: Distinguish ‘output’ and ‘item’ parameter.
perform-download: Allow use of ‘download-nar’ for ‘--check’ builds.
download: Honor ‘GUIX_DOWNLOAD_METHODS’ environment variable.

guix/build/bzr.scm | 3 +-
guix/build/download-nar.scm | 12 +--
guix/build/download.scm | 50 +++++++---
guix/build/git.scm | 27 ++++--
guix/bzr-download.scm | 57 ++++++++---
guix/cvs-download.scm | 24 +++--
guix/download.scm | 53 ++++-------
guix/git-download.scm | 20 ++--
guix/hg-download.scm | 36 ++++---
guix/lint.scm | 151 +++++++++++++++++++-----------
guix/scripts/perform-download.scm | 67 +++++++------
guix/svn-download.scm | 88 +++++++++++------
guix/swh.scm | 71 ++++++++------
tests/lint.scm | 20 ++++
tests/swh.scm | 74 +++++++++++++++
15 files changed, 507 insertions(+), 246 deletions(-)


base-commit: b7f0aad907d6c33c4ccb137190b7a6b710a7112b
--
2.41.0
L
L
Ludovic Courtès wrote on 5 Mar 12:06 +0100
[PATCH v2 02/12] lint: archival: Fix crash in non-Git case.
(address . 69328@debbugs.gnu.org)
395f0625fc5373cee2de0793a98ea57a4059cc7d.1709636144.git.ludo@gnu.org
Fixes a bug introduced in 29f3089c841f00144f24f5c32296aebf22d752cc where
‘guix lint -c archival guile-wisp’ (for instance) would crash with a
match error because ‘lookup-by-nar-hash’ returns a string.

* guix/lint.scm (check-archival): Add SWHID case in the non-Git case.

Change-Id: I66fb060172d372041df47d90a14df168b0fa762d
---
guix/lint.scm | 2 ++
1 file changed, 2 insertions(+)

Toggle diff (15 lines)
diff --git a/guix/lint.scm b/guix/lint.scm
index 84df171045..ad84048660 100644
--- a/guix/lint.scm
+++ b/guix/lint.scm
@@ -1736,6 +1736,8 @@ (define (check-archival package)
(list id)
#:field 'source)))))))
((? content?)
+ '())
+ ((? string? swhid)
'())))
'()))
((? local-file?)
--
2.41.0
L
L
Ludovic Courtès wrote on 5 Mar 12:06 +0100
[PATCH v2 01/12] lint: Switch to SRFI-71.
(address . 69328@debbugs.gnu.org)
ae88a62f7115d42f83b7b93ddd79175f095d0100.1709636144.git.ludo@gnu.org
* guix/lint.scm: Switch from SRFI-11 to SRFI-71.

Change-Id: I62e6cd304ad73570bd12bd67f7051566205596bb
---
guix/lint.scm | 9 ++++-----
1 file changed, 4 insertions(+), 5 deletions(-)

Toggle diff (39 lines)
diff --git a/guix/lint.scm b/guix/lint.scm
index c95de85e69..84df171045 100644
--- a/guix/lint.scm
+++ b/guix/lint.scm
@@ -84,10 +84,10 @@ (define-module (guix lint)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-6) ;Unicode string ports
#:use-module (srfi srfi-9)
- #:use-module (srfi srfi-11)
#:use-module (srfi srfi-26)
#:use-module (srfi srfi-34)
#:use-module (srfi srfi-35)
+ #:use-module (srfi srfi-71)
#:use-module (ice-9 rdelim)
#:export (check-description-style
check-inputs-should-be-native
@@ -823,8 +823,8 @@ (define* (probe-uri uri #:key timeout)
;; Return RESPONSE, unless the final response as we follow
;; redirects is not 200.
(if location
- (let-values (((status response2)
- (loop location (cons location visited))))
+ (let ((status response2 (loop location
+ (cons location visited))))
(case status
((http-response)
(values 'http-response
@@ -926,8 +926,7 @@ (define (tls-certificate-error-string args)
(define (validate-uri uri package field)
"Return #t if the given URI can be reached, otherwise return a warning for
PACKAGE mentioning the FIELD."
- (let-values (((status argument)
- (probe-uri uri #:timeout 3))) ;wait at most 3 seconds
+ (let ((status argument (probe-uri uri #:timeout 3))) ;wait at most 3 seconds
(case status
((http-response)
(cond ((= 200 (response-code argument))
--
2.41.0
L
L
Ludovic Courtès wrote on 5 Mar 12:06 +0100
[PATCH v2 04/12] swh: Add ‘type’ field to <visit>.
(address . 69328@debbugs.gnu.org)
a94c6c23b0b263bfa4f5a4872ac60f73995fa880.1709636144.git.ludo@gnu.org
* guix/swh.scm (<visit>)[type]: New field.

Change-Id: I7677984c7daef38d8f3c3bef19723fa0efb035ba
---
guix/swh.scm | 2 ++
1 file changed, 2 insertions(+)

Toggle diff (22 lines)
diff --git a/guix/swh.scm b/guix/swh.scm
index 04cecd854c..83f67423c8 100644
--- a/guix/swh.scm
+++ b/guix/swh.scm
@@ -54,6 +54,7 @@ (define-module (guix swh)
visit-snapshot-url
visit-status
visit-number
+ visit-type
visit-snapshot
snapshot?
@@ -312,6 +313,7 @@ (define-json-mapping <visit> make-visit visit?
(url visit-url "origin_visit_url")
(snapshot-url visit-snapshot-url "snapshot_url" string*) ;string | #f
(status visit-status "status" string->symbol) ;'full | 'partial | 'ongoing
+ (type visit-type "type" string->symbol) ;'git | 'git-checkout | ...
(number visit-number "visit"))
;; <https://archive.softwareheritage.org/api/1/snapshot/4334c3ed4bb208604ed780d8687fe523837f1bd1/>
--
2.41.0
L
L
Ludovic Courtès wrote on 5 Mar 12:06 +0100
[PATCH v2 05/12] swh: ‘origin-visits’ takes an optional ‘max’ parameter.
(address . 69328@debbugs.gnu.org)
170679e479acdb28dbe721f77e4368098e7cd97e.1709636144.git.ludo@gnu.org
* guix/swh.scm (origin-visits): Add optional ‘max’ parameter and honor
it.

Change-Id: I642d7d4b0672b68fb5c7ce2b49161307e13d3c95
---
guix/swh.scm | 9 +++++----
1 file changed, 5 insertions(+), 4 deletions(-)

Toggle diff (22 lines)
diff --git a/guix/swh.scm b/guix/swh.scm
index 83f67423c8..14c65f6806 100644
--- a/guix/swh.scm
+++ b/guix/swh.scm
@@ -474,10 +474,11 @@ (define* (lookup-directory-by-nar-hash hash #:optional (algorithm 'sha256))
hash)
external-id-target))
-(define (origin-visits origin)
- "Return the list of visits of ORIGIN, a record as returned by
-'lookup-origin'."
- (call (swh-url (origin-visits-url origin))
+(define* (origin-visits origin #:optional (max 10))
+ "Return the list of the up to MAX latest visits of ORIGIN, a record as
+returned by 'lookup-origin'."
+ (call (string-append (swh-url (origin-visits-url origin))
+ "?per_page=" (number->string max))
(lambda (port)
(map json->visit (vector->list (json->scm port))))))
--
2.41.0
L
L
Ludovic Courtès wrote on 5 Mar 12:06 +0100
[PATCH v2 03/12] lint: archival: Trigger “Save Code Now” for VCSes other tha n Git.
(address . 69328@debbugs.gnu.org)
3ca956c57b34c820ee0e43a71334a512079c3732.1709636144.git.ludo@gnu.org
From: Ludovic Courtès <ludovic.courtes@inria.fr>

Until now, ‘save-origin’ would be called only when given a
<git-reference>. With this change, ‘save-origin’ gets called for other
version control systems as well.

* guix/lint.scm (swh-response->warning): New procedure, formerly in
‘check-archival’.
(vcs-origin, save-package-source): New procedures.
(check-archival)[response->warning]: Remove.
Call ‘save-package-source’ in both the Git and the non-Git cases.
* tests/lint.scm ("archival: missing svn revision"): New test.

Change-Id: I535e4ec89488faf83bfa544d5e4935fa73ef54fb
---
guix/lint.scm | 140 +++++++++++++++++++++++++++++++------------------
tests/lint.scm | 20 +++++++
2 files changed, 109 insertions(+), 51 deletions(-)

Toggle diff (222 lines)
diff --git a/guix/lint.scm b/guix/lint.scm
index ad84048660..68d532968d 100644
--- a/guix/lint.scm
+++ b/guix/lint.scm
@@ -67,6 +67,10 @@ (define-module (guix lint)
svn-multi-reference-url
svn-multi-reference-user-name
svn-multi-reference-password)
+ #:autoload (guix hg-download) (hg-reference?
+ hg-reference-url)
+ #:autoload (guix bzr-download) (bzr-reference?
+ bzr-reference-url)
#:use-module (guix import stackage)
#:use-module (ice-9 match)
#:use-module (ice-9 regex)
@@ -1632,6 +1636,69 @@ (define (lookup-disarchive-spec hash)
(extract-swh-id spec)))))
%disarchive-mirrors))
+(define (swh-response->warning package url method response)
+ "Given RESPONSE, the response of METHOD on URL, return a suitable warning
+list for PACKAGE."
+ (if (request-rate-limit-reached? url method)
+ (list (make-warning package
+ (G_ "Software Heritage rate limit reached; \
+try again later")
+ #:field 'source))
+ (list (make-warning package
+ (G_ "'~a' returned ~a")
+ (list url (response-code response))
+ #:field 'source))))
+
+(define (vcs-origin origin)
+ "Return two values: the URL and type (a string) of the version-control used
+for ORIGIN. Return #f and #f if ORIGIN is not a version-control checkout."
+ (match (and=> origin origin-uri)
+ ((? git-reference? ref)
+ (values (git-reference-url ref) "git"))
+ ((? svn-reference? ref)
+ (values (svn-reference-url ref) "svn"))
+ ((? svn-multi-reference? ref)
+ (values (svn-multi-reference-url ref) "svn"))
+ ((? hg-reference? ref)
+ (values (hg-reference-url ref) "hg"))
+ ((? bzr-reference? ref)
+ (values (bzr-reference-url ref) "bzr"))
+ ;; XXX: Not sure what to do with the weird CVS URIs (:pserver: etc.).
+ (_
+ (values #f #f))))
+
+(define (save-package-source package)
+ "Attempt to save the source of PACKAGE on SWH. Return a list of warnings."
+ (let* ((origin (package-source package))
+ (url type (if origin (vcs-origin origin) (values #f #f))))
+ (cond ((and url type)
+ (catch 'swh-error
+ (lambda ()
+ (save-origin url type)
+ (list (make-warning
+ package
+ ;; TRANSLATORS: "Software Heritage" is a proper noun that
+ ;; must remain untranslated. See
+ ;; <https://www.softwareheritage.org>.
+ (G_ "scheduled Software Heritage archival")
+ #:field 'source)))
+ (lambda (key url method response . _)
+ (cond ((= 429 (response-code response))
+ (list (make-warning
+ package
+ (G_ "archival rate limit exceeded; \
+try again later")
+ #:field 'source)))
+ (else
+ (swh-response->warning package url method response))))))
+ ((not origin)
+ '())
+ (else
+ (list (make-warning
+ package
+ (G_ "source code cannot be archived")
+ #:field 'source))))))
+
(define (check-archival package)
"Check whether PACKAGE's source code is archived on Software Heritage. If
it's not, and if its source code is a VCS snapshot, then send a \"save\"
@@ -1640,17 +1707,6 @@ (define (check-archival package)
Software Heritage imposes limits on the request rate per client IP address.
This checker prints a notice and stops doing anything once that limit has been
reached."
- (define (response->warning url method response)
- (if (request-rate-limit-reached? url method)
- (list (make-warning package
- (G_ "Software Heritage rate limit reached; \
-try again later")
- #:field 'source))
- (list (make-warning package
- (G_ "'~a' returned ~a")
- (list url (response-code response))
- #:field 'source))))
-
(define skip-key (gensym "skip-archival-check"))
(define (skip-when-limit-reached url method)
@@ -1685,28 +1741,8 @@ (define (check-archival package)
'())
(#f
;; Revision is missing from the archive, attempt to save it.
- (catch 'swh-error
- (lambda ()
- (save-origin (git-reference-url reference) "git")
- (list (make-warning
- package
- ;; TRANSLATORS: "Software Heritage" is a proper noun
- ;; that must remain untranslated. See
- ;; <https://www.softwareheritage.org>.
- (G_ "scheduled Software Heritage archival")
- #:field 'source)))
- (lambda (key url method response . _)
- (cond ((= 429 (response-code response))
- (list (make-warning
- package
- (G_ "archival rate limit exceeded; \
-try again later")
- #:field 'source)))
- (else
- (response->warning url method response))))))))
+ (save-package-source package))))
((? origin? origin)
- ;; Since "save" origins are not supported for non-VCS source, all
- ;; we can do is tell whether a given tarball is available or not.
(if (and=> (origin-hash origin) ;XXX: for ungoogled-chromium
content-hash-value) ;& icecat
(let ((hash (origin-hash origin)))
@@ -1715,26 +1751,28 @@ (define (check-archival package)
(symbol->string
(content-hash-algorithm hash))))
(#f
- ;; If SWH doesn't have HASH as is, it may be because it's
- ;; a hand-crafted tarball. In that case, check whether
- ;; the Disarchive database has an entry for that tarball.
- (match (lookup-disarchive-spec hash)
- (#f
- (list (make-warning package
- (G_ "source not archived on Software \
+ ;; If ORIGIN is a version-control checkout, save it now.
+ ;; If not, check whether HASH is in the Disarchive
+ ;; database ("Save Code Now" does not accept tarballs).
+ (if (vcs-origin origin)
+ (save-package-source package)
+ (match (lookup-disarchive-spec hash)
+ (#f
+ (list (make-warning package
+ (G_ "source not archived on Software \
Heritage and missing from the Disarchive database")
- #:field 'source)))
- (directory-ids
- (match (find (lambda (id)
- (not (lookup-directory id)))
- directory-ids)
- (#f '())
- (id
- (list (make-warning package
- (G_ "\
+ #:field 'source)))
+ (directory-ids
+ (match (find (lambda (id)
+ (not (lookup-directory id)))
+ directory-ids)
+ (#f '())
+ (id
+ (list (make-warning package
+ (G_ "\
Disarchive entry refers to non-existent SWH directory '~a'")
- (list id)
- #:field 'source)))))))
+ (list id)
+ #:field 'source))))))))
((? content?)
'())
((? string? swhid)
@@ -1749,7 +1787,7 @@ (define (check-archival package)
#:field 'source)))))
(match-lambda*
(('swh-error url method response)
- (response->warning url method response))
+ (swh-response->warning package url method response))
((key . args)
(if (eq? key skip-key)
'()
diff --git a/tests/lint.scm b/tests/lint.scm
index 87213fcc78..95d82d7490 100644
--- a/tests/lint.scm
+++ b/tests/lint.scm
@@ -1407,6 +1407,26 @@ (define (package-with-phase-changes changes)
(check-archival (dummy-package "x" (source origin)))))))
(warning-contains? "scheduled" warnings)))
+(test-assert "archival: missing svn revision"
+ (let* ((origin (origin
+ (method svn-fetch)
+ (uri (svn-reference
+ (url "http://example.org/svn/foo")
+ (revision "1234")))
+ (sha256 (make-bytevector 32))))
+ ;; https://archive.softwareheritage.org/api/1/origin/save/
+ (save "{ \"origin_url\": \"http://example.org/svn/foo\",
+ \"save_request_date\": \"2014-11-17T22:09:38+01:00\",
+ \"save_request_status\": \"accepted\",
+ \"save_task_status\": \"scheduled\" }")
+ (warnings (with-http-server `((404 "No extid.") ;lookup-directory-by-nar-hash
+ (404 "No revision.") ;lookup-revision
+ (404 "No origin.") ;lookup-origin
+ (200 ,save)) ;save-origin
+ (parameterize ((%swh-base-url (%local-url)))
+ (check-archival (dummy-package "x" (source origin)))))))
+ (warning-contains? "scheduled" warnings)))
+
(test-equal "archival: revision available"
'()
(let* ((origin (origin
--
2.41.0
L
L
Ludovic Courtès wrote on 5 Mar 12:06 +0100
[PATCH v2 06/12] swh: ‘lookup-origin-revision ’ handles branches pointing to directories.
(address . 69328@debbugs.gnu.org)
a804bc4c70856b8a53fce9a450c60775bd459f18.1709636144.git.ludo@gnu.org

* guix/swh.scm (branch-target): Add clause for 'directory and 'alias.
(lookup-origin-revision): Iterate over all the visits of ORIGIN instead
of just the first one. Handle the case where ‘branch-target’ returns
something other than a release or revision.
* tests/swh.scm ("lookup-origin-revision"): New test.

Change-Id: I7f636739a719908763bca1d3e7376341dd62e816
---
guix/swh.scm | 60 ++++++++++++++++++++++-------------------
tests/swh.scm | 74 +++++++++++++++++++++++++++++++++++++++++++++++++++
2 files changed, 107 insertions(+), 27 deletions(-)

Toggle diff (171 lines)
diff --git a/guix/swh.scm b/guix/swh.scm
index 14c65f6806..f602cd89d1 100644
--- a/guix/swh.scm
+++ b/guix/swh.scm
@@ -516,14 +516,20 @@ (define (lookup-snapshot-branch snapshot name)
(_ #f)))))
(define (branch-target branch)
- "Return the target of BRANCH, either a <revision> or a <release>."
+ "Return the target of BRANCH: a <revision>, a <release>, or the SWHID of a
+directory."
(match (branch-target-type branch)
('release
(call (swh-url (branch-target-url branch))
json->release))
('revision
(call (swh-url (branch-target-url branch))
- json->revision))))
+ json->revision))
+ ((or 'directory 'alias)
+ (match (string-tokenize (branch-target-url branch)
+ (char-set-complement (char-set #\/)))
+ ((_ ... "directory" id)
+ (string-append "swh:1:dir:" id))))))
(define (lookup-origin-revision url tag)
"Return a <revision> corresponding to the given TAG for the repository
@@ -537,31 +543,31 @@ (define (lookup-origin-revision url tag)
(match (lookup-origin url)
(#f #f)
(origin
- (match (filter (lambda (visit)
- ;; Return #f if (visit-snapshot VISIT) would return #f.
- (and (visit-snapshot-url visit)
- (eq? 'full (visit-status visit))))
- (origin-visits origin))
- ((visit . _)
- (let ((snapshot (visit-snapshot visit)))
- (match (and=> (find (lambda (branch)
- (or
- ;; Git specific.
- (string=? (string-append "refs/tags/" tag)
- (branch-name branch))
- ;; Hg specific.
- (string=? tag
- (branch-name branch))))
- (snapshot-branches snapshot))
- branch-target)
- ((? release? release)
- (release-target release))
- ((? revision? revision)
- revision)
- (#f ;tag not found
- #f))))
- (()
- #f)))))
+ (any (lambda (visit)
+ (and (visit-snapshot-url visit)
+ (eq? 'full (visit-status visit))
+ (let ((snapshot (visit-snapshot visit)))
+ (match (and=> (find (lambda (branch)
+ (or
+ ;; Git specific.
+ (string=? (string-append "refs/tags/" tag)
+ (branch-name branch))
+ ;; Hg specific.
+ (string=? tag
+ (branch-name branch))))
+ (snapshot-branches snapshot))
+ branch-target)
+ ((? release? release)
+ (release-target release))
+ ((? revision? revision)
+ revision)
+ (_
+ ;; Either the branch points to a directory rather than
+ ;; a revision (this is the case for visits of type
+ ;; 'git-checkout, 'hg-checkout, 'tarball-directory,
+ ;; etc.), or TAG was not found.
+ #f)))))
+ (origin-visits origin 30)))))
(define (release-target release)
"Return the revision that is the target of RELEASE."
diff --git a/tests/swh.scm b/tests/swh.scm
index e7ced6b50c..11dcbdddd8 100644
--- a/tests/swh.scm
+++ b/tests/swh.scm
@@ -109,6 +109,80 @@ (define-syntax-rule (with-json-result str exp ...)
(directory-entry-length entry)))
(lookup-directory "123"))))
+(test-equal "lookup-origin-revision"
+ '("cd86c72084993d9ef26fc9e24b73cea612b8c97b"
+ "d173c707ee88e3c89401ad77fafa65fcd9e9f5be")
+ (let ()
+ ;; Make sure that 'lookup-origin-revision' does the job, and in particular
+ ;; that it doesn't stop until it has found an actual revision:
+ ;; 'git-checkout visits point to directories instead of revisions.
+ ;; See <https://issues.guix.gnu.org/69070>.
+ (define visits
+ ;; Two visits of differing types: the first visit (type 'git-checkout')
+ ;; points to a directory, the second one (type 'git') points to a
+ ;; revision.
+ "[ {
+ \"origin\": \"https://example.org/repo.git\",
+ \"visit\": 1,
+ \"type\": \"git-checkout\",
+ \"date\": \"2020-05-17T21:43:45.422977+00:00\",
+ \"status\": \"full\",
+ \"metadata\": {},
+ \"type\": \"git-checkout\",
+ \"origin_visit_url\": \"/visit/42\",
+ \"snapshot_url\": \"/snapshot/1\"
+ }, {
+ \"origin\": \"https://example.org/repo.git\",
+ \"visit\": 2,
+ \"type\": \"git\",
+ \"date\": \"2020-05-17T21:43:49.422977+00:00\",
+ \"status\": \"full\",
+ \"metadata\": {},
+ \"type\": \"git\",
+ \"origin_visit_url\": \"/visit/41\",
+ \"snapshot_url\": \"/snapshot/2\"
+ } ]")
+ (define snapshot-for-git-checkout
+ "{ \"id\": 42,
+ \"branches\": { \"1.3.2\": {
+ \"target\": \"e4a4be18fae8d9c6528abff3bc9088feb19a76c7\",
+ \"target_type\": \"directory\",
+ \"target_url\": \"/directory/e4a4be18fae8d9c6528abff3bc9088feb19a76c7\"
+ }}
+ }")
+ (define snapshot-for-git
+ "{ \"id\": 42,
+ \"branches\": { \"1.3.2\": {
+ \"target\": \"e4a4be18fae8d9c6528abff3bc9088feb19a76c7\",
+ \"target_type\": \"revision\",
+ \"target_url\": \"/revision/e4a4be18fae8d9c6528abff3bc9088feb19a76c7\"
+ }}
+ }")
+ (define revision
+ "{ \"author\": {},
+ \"committer\": {},
+ \"committer_date\": \"2018-05-17T21:43:49.422977+00:00\",
+ \"date\": \"2018-05-17T21:43:49.422977+00:00\",
+ \"directory\": \"d173c707ee88e3c89401ad77fafa65fcd9e9f5be\",
+ \"directory_url\": \"/directory/d173c707ee88e3c89401ad77fafa65fcd9e9f5be\",
+ \"id\": \"cd86c72084993d9ef26fc9e24b73cea612b8c97b\",
+ \"merge\": false,
+ \"message\": \"Fix.\",
+ \"parents\": [],
+ \"type\": \"what type?\"
+ }")
+
+ (with-http-server `((200 ,%origin)
+ (200 ,visits)
+ (200 ,snapshot-for-git-checkout)
+ (200 ,snapshot-for-git)
+ (200 ,revision))
+ (parameterize ((%swh-base-url (%local-url)))
+ (let ((revision (lookup-origin-revision "https://example.org/repo.git"
+ "1.3.2")))
+ (list (revision-id revision)
+ (revision-directory revision)))))))
+
(test-equal "lookup-directory-by-nar-hash"
"swh:1:dir:84a8b34591712c0a90bab0af604188bcd1fe3153"
(with-json-result %external-id
--
2.41.0
L
L
Ludovic Courtès wrote on 5 Mar 12:06 +0100
[PATCH v2 07/12] hg-download: Use ‘swh-down load-directory-by-nar-hash’.
(address . 69328@debbugs.gnu.org)
f4532ceb09146b4d21daa2a029a12a4015727418.1709636144.git.ludo@gnu.org
This allows content-addressed access to the checkout, which is
preferable.

* guix/hg-download.scm (hg-fetch): Add call to
‘swh-download-directory-by-nar-hash’ before ‘swh-download’ call.

Change-Id: I2afc8badc1f8bb2c8bdd3a47abbb72d455d93e64
---
guix/hg-download.scm | 10 ++++++----
1 file changed, 6 insertions(+), 4 deletions(-)

Toggle diff (28 lines)
diff --git a/guix/hg-download.scm b/guix/hg-download.scm
index 6d02de47e4..dd28d9c244 100644
--- a/guix/hg-download.scm
+++ b/guix/hg-download.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2014, 2015, 2016, 2017, 2019 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2014-2017, 2019, 2024 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2016 Ricardo Wurmus <rekado@elephly.net>
;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz>
;;;
@@ -117,9 +117,11 @@ (define* (hg-fetch ref hash-algo hash
(parameterize ((%verify-swh-certificate? #f))
(format (current-error-port)
"Trying to download from Software Heritage...~%")
- (swh-download #$(hg-reference-url ref)
- #$(hg-reference-changeset ref)
- #$output)))))))
+ (or (swh-download-directory-by-nar-hash #$hash '#$hash-algo
+ #$output)
+ (swh-download #$(hg-reference-url ref)
+ #$(hg-reference-changeset ref)
+ #$output))))))))
(mlet %store-monad ((guile (package->derivation guile system)))
(gexp->derivation (or name "hg-checkout") build
--
2.41.0
L
L
Ludovic Courtès wrote on 5 Mar 12:06 +0100
[PATCH v2 09/12] bzr-download: Implement nar fallback.
(address . 69328@debbugs.gnu.org)
09b424cf6c561426047790d7bca50055b5caad21.1709636144.git.ludo@gnu.org
* guix/bzr-download.scm (bzr-fetch)[guile-json, guile-lzlib,
guile-gnutls]: New variables.
[build]: Add ‘with-extensions’ and import more modules. Invoke
‘download-nar’ when ‘bzr-fetch’ returns #f.
* guix/build/bzr.scm (bzr-fetch): Actually return #t on success.

Change-Id: Id5d4ebd0f9ddc3c44b6456d3b46c0000cc7b9997
---
guix/build/bzr.scm | 3 ++-
guix/bzr-download.scm | 43 ++++++++++++++++++++++++++++++++-----------
2 files changed, 34 insertions(+), 12 deletions(-)

Toggle diff (86 lines)
diff --git a/guix/build/bzr.scm b/guix/build/bzr.scm
index a0f5e15880..dede5e031a 100644
--- a/guix/build/bzr.scm
+++ b/guix/build/bzr.scm
@@ -37,6 +37,7 @@ (define* (bzr-fetch url revision directory
(invoke bzr-command "-Ossl.cert_reqs=none" "checkout"
"--lightweight" "-r" revision url directory)
(with-directory-excursion directory
- (delete-file-recursively ".bzr")))
+ (delete-file-recursively ".bzr"))
+ #t)
;;; bzr.scm ends here
diff --git a/guix/bzr-download.scm b/guix/bzr-download.scm
index d97f84838e..01c12fd54d 100644
--- a/guix/bzr-download.scm
+++ b/guix/bzr-download.scm
@@ -1,5 +1,6 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2017, 2022 Maxim Cournoyer <maxim.cournoyer@gmail.com>
+;;; Copyright © 2024 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -51,20 +52,40 @@ (define (bzr-package)
(module-ref distro 'breezy)))
(define* (bzr-fetch ref hash-algo hash
- #:optional name
- #:key (system (%current-system)) (guile (default-guile))
- (bzr (bzr-package)))
+ #:optional name
+ #:key (system (%current-system)) (guile (default-guile))
+ (bzr (bzr-package)))
"Return a fixed-output derivation that fetches REF, a <bzr-reference>
object. The output is expected to have recursive hash HASH of type
HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #f."
+ (define guile-json
+ (module-ref (resolve-interface '(gnu packages guile)) 'guile-json-4))
+
+ (define guile-lzlib
+ (module-ref (resolve-interface '(gnu packages guile)) 'guile-lzlib))
+
+ (define guile-gnutls
+ (module-ref (resolve-interface '(gnu packages tls)) 'guile-gnutls))
+
(define build
- (with-imported-modules (source-module-closure
- '((guix build bzr)))
- #~(begin
- (use-modules (guix build bzr))
- (bzr-fetch
- (getenv "bzr url") (getenv "bzr reference") #$output
- #:bzr-command (string-append #+bzr "/bin/brz")))))
+ (with-extensions (list guile-gnutls guile-lzlib guile-json)
+ (with-imported-modules (source-module-closure
+ '((guix build bzr)
+ (guix build utils)
+ (guix build download-nar)))
+ #~(begin
+ (use-modules (guix build bzr)
+ (guix build download-nar)
+ (guix build utils)
+ (srfi srfi-34))
+
+ (or (guard (c ((invoke-error? c)
+ (report-invoke-error c)
+ #f))
+ (bzr-fetch (getenv "bzr url") (getenv "bzr reference")
+ #$output
+ #:bzr-command (string-append #+bzr "/bin/brz")))
+ (download-nar #$output))))))
(mlet %store-monad ((guile (package->derivation guile system)))
(gexp->derivation (or name "bzr-branch") build
@@ -79,7 +100,7 @@ (define* (bzr-fetch ref hash-algo hash
"LC_ALL" "LC_MESSAGES" "LANG"
"COLUMNS")
#:system system
- #:local-build? #t ;don't offload repo branching
+ #:local-build? #t ;don't offload repo branching
#:hash-algo hash-algo
#:hash hash
#:recursive? #t
--
2.41.0
L
L
Ludovic Courtès wrote on 5 Mar 12:06 +0100
[PATCH v2 08/12] svn-download: Use ‘swh-dow nload-directory-by-nar-hash’.
(address . 69328@debbugs.gnu.org)
81113a322b0f885ed0e09867b00a1ca46c6c7bbd.1709636144.git.ludo@gnu.org

* guix/svn-download.scm (svn-fetch)[build]: Add
‘swh-download-directory-by-nar-hash’ call as a last resort.
Import (guix swh).
* guix/svn-download.scm (svn-multi-fetch)[build]: Likewise.

Change-Id: Ifcb9be1e9c2b05ce172c44e45dcf3a3ea6df8e76
---
guix/svn-download.scm | 24 +++++++++++++++++++-----
1 file changed, 19 insertions(+), 5 deletions(-)

Toggle diff (74 lines)
diff --git a/guix/svn-download.scm b/guix/svn-download.scm
index c6688908de..64af996a06 100644
--- a/guix/svn-download.scm
+++ b/guix/svn-download.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2014-2016, 2019, 2021-2023 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2014-2016, 2019, 2021-2024 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2014 Sree Harsha Totakura <sreeharsha@totakura.in>
;;; Copyright © 2017, 2019, 2021 Ricardo Wurmus <rekado@elephly.net>
;;;
@@ -94,12 +94,14 @@ (define* (svn-fetch ref hash-algo hash
(with-imported-modules
(source-module-closure '((guix build svn)
(guix build download-nar)
- (guix build utils)))
+ (guix build utils)
+ (guix swh)))
(with-extensions (list guile-json guile-gnutls ;for (guix swh)
guile-lzlib)
#~(begin
(use-modules (guix build svn)
(guix build download-nar)
+ (guix swh)
(ice-9 match))
(or (svn-fetch (getenv "svn url")
@@ -111,7 +113,10 @@ (define* (svn-fetch ref hash-algo hash
(_ #f))
#:user-name (getenv "svn user name")
#:password (getenv "svn password"))
- (download-nar #$output))))))
+ (download-nar #$output)
+ (parameterize ((%verify-swh-certificate? #f))
+ (swh-download-directory-by-nar-hash #$hash '#$hash-algo
+ #$output)))))))
(mlet %store-monad ((guile (package->derivation guile system)))
(gexp->derivation (or name "svn-checkout") build
@@ -174,13 +179,15 @@ (define* (svn-multi-fetch ref hash-algo hash
(with-imported-modules
(source-module-closure '((guix build svn)
(guix build download-nar)
- (guix build utils)))
+ (guix build utils)
+ (guix swh)))
(with-extensions (list guile-json guile-gnutls ;for (guix swh)
guile-lzlib)
#~(begin
(use-modules (guix build svn)
(guix build utils)
(guix build download-nar)
+ (guix swh)
(srfi srfi-1)
(ice-9 match))
@@ -206,7 +213,14 @@ (define* (svn-multi-fetch ref hash-algo hash
(begin
(when (file-exists? #$output)
(delete-file-recursively #$output))
- (download-nar #$output)))))))
+ (or (download-nar #$output)
+ (parameterize ((%verify-swh-certificate? #f))
+ ;; SWH keeps HASH as an ExtID for the combination of
+ ;; files/directories, which allows us to retrieve the
+ ;; entire combination at once:
+ ;; <https://gitlab.softwareheritage.org/swh/infra/sysadm-environment/-/issues/5263>.
+ (swh-download-directory-by-nar-hash
+ #$hash '#$hash-algo #$output)))))))))
(mlet %store-monad ((guile (package->derivation guile system)))
(gexp->derivation (or name "svn-checkout") build
--
2.41.0
L
L
Ludovic Courtès wrote on 5 Mar 12:06 +0100
[PATCH v2 10/12] download-nar: Distinguish ‘output’ and ‘item’ param eter.
(address . 69328@debbugs.gnu.org)
559b047af3adb608ef8245faadb0c7089dd2de1a.1709636144.git.ludo@gnu.org
This is useful when running a ‘--check’ build, where the output file
name differs from the store file name we are trying to restore.

* guix/build/download-nar.scm (download-nar): Add ‘output’ parameter and
distinguish it from ‘item’.

Change-Id: I42219b6d4c8fd1ed506720301384efc1aa351561
---
guix/build/download-nar.scm | 12 ++++++------
1 file changed, 6 insertions(+), 6 deletions(-)

Toggle diff (39 lines)
diff --git a/guix/build/download-nar.scm b/guix/build/download-nar.scm
index 3ba121b7fb..f26ad28cd0 100644
--- a/guix/build/download-nar.scm
+++ b/guix/build/download-nar.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2017, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2017, 2019, 2020, 2024 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -57,9 +57,9 @@ (define (restore-lzipped-nar port item size)
(restore-file decompressed-port
item))))
-(define (download-nar item)
- "Download and extract the normalized archive for ITEM. Return #t on
-success, #f otherwise."
+(define* (download-nar item #:optional (output item))
+ "Download and extract to OUTPUT the normalized archive for ITEM, a store
+item. Return #t on success, #f otherwise."
;; Let progress reports go through.
(setvbuf (current-error-port) 'none)
(setvbuf (current-output-port) 'none)
@@ -96,10 +96,10 @@ (define (download-nar item)
#:download-size size)))
(if (string-contains url "/lzip")
(restore-lzipped-nar port-with-progress
- item
+ output
size)
(restore-file port-with-progress
- item)))
+ output)))
(newline)
#t))))
(()
--
2.41.0
L
L
Ludovic Courtès wrote on 5 Mar 12:06 +0100
[PATCH v2 11/12] perform-download: Allow use of ‘download-nar’ for ‘--check ’ builds.
(address . 69328@debbugs.gnu.org)
06837fef6279131031f9fe5a176624167c3d46b0.1709636144.git.ludo@gnu.org
Previously, the nar fallback would always fail on ‘--check’ build
because the output directory in that case is different from the store
file name. This change fixes that.

* guix/build/git.scm (git-fetch-with-fallback): Add #:item parameter and
pass it to ‘download-nar’.
* guix/scripts/perform-download.scm (perform-git-download): Pass #:item
to ‘git-fetch-with-fallback’.

Change-Id: I30fc948718e99574005150bba5215a51ef153c49
---
guix/build/git.scm | 14 ++++++++------
guix/scripts/perform-download.scm | 3 +++
2 files changed, 11 insertions(+), 6 deletions(-)

Toggle diff (52 lines)
diff --git a/guix/build/git.scm b/guix/build/git.scm
index 4c69365a7b..a135026fae 100644
--- a/guix/build/git.scm
+++ b/guix/build/git.scm
@@ -92,19 +92,21 @@ (define* (git-fetch url commit directory
(define* (git-fetch-with-fallback url commit directory
- #:key (git-command "git")
+ #:key (item directory)
+ (git-command "git")
hash hash-algorithm
lfs? recursive?)
"Like 'git-fetch', fetch COMMIT from URL into DIRECTORY, but fall back to
-alternative methods when fetching from URL fails: attempt to download a nar,
-and if that also fails, download from the Software Heritage archive. When
-HASH and HASH-ALGORITHM are provided, they are interpreted as the nar hash of
-the directory of interested and are used as its content address at SWH."
+alternative methods when fetching from URL fails: attempt to download a nar
+for ITEM, and if that also fails, download from the Software Heritage archive.
+When HASH and HASH-ALGORITHM are provided, they are interpreted as the nar
+hash of the directory of interested and are used as its content address at
+SWH."
(or (git-fetch url commit directory
#:lfs? lfs?
#:recursive? recursive?
#:git-command git-command)
- (download-nar directory)
+ (download-nar item directory)
;; As a last resort, attempt to download from Software Heritage.
;; Disable X.509 certificate verification to avoid depending
diff --git a/guix/scripts/perform-download.scm b/guix/scripts/perform-download.scm
index e7eb3b2a1f..b96959a09e 100644
--- a/guix/scripts/perform-download.scm
+++ b/guix/scripts/perform-download.scm
@@ -114,10 +114,13 @@ (define* (perform-git-download drv output
;; on ambient authority, hence the PATH value below.
(setenv "PATH" "/run/current-system/profile/bin:/bin:/usr/bin")
+ ;; Note: When doing a '--check' build, DRV-OUTPUT and OUTPUT are
+ ;; different, hence the #:item argument below.
(git-fetch-with-fallback url commit output
#:hash hash
#:hash-algorithm algo
#:recursive? recursive?
+ #:item (derivation-output-path drv-output)
#:git-command %git))))
(define (assert-low-privileges)
--
2.41.0
L
L
Ludovic Courtès wrote on 5 Mar 12:07 +0100
[PATCH v2 12/12] download: Honor ‘GUIX_DO WNLOAD_METHODS’ environment variable.
(address . 69328@debbugs.gnu.org)
e893fbe58507224a6f7bba6c9f8a1b77dcdd600a.1709636144.git.ludo@gnu.org
This replaces ‘GUIX_DOWNLOAD_FALLBACK_TEST’ and allows you to test
various download methods, like so:

GUIX_DOWNLOAD_METHODS=nar guix build guile-gcrypt -S --check
GUIX_DOWNLOAD_METHODS=disarchive guix build hello -S --check

* guix/build/download.scm (%download-methods): New variable.
(download-method-enabled?): New procedure.
(url-fetch): Define ‘initial-uris’; honor ‘download-method-enabled?’.
Call ‘disarchive-fetch/any’ only when the 'disarchive method is enabled.
* guix/build/git.scm (git-fetch-with-fallback): Honor
‘download-method-enabled?’.
* guix/download.scm (%download-methods): New variable.
(%download-fallback-test): Remove.
(built-in-download): Add #:download-methods parameter and honor it.
(url-fetch*): Pass #:content-addressed-mirrors and #:disarchive-mirrors
unconditionally.
* guix/git-download.scm (git-fetch/in-band*): Pass “git url”
unconditionally.
(git-fetch/built-in): Likewise. Pass “download-methods”.
* guix/bzr-download.scm (bzr-fetch)[build]: Honor ‘download-method-enabled?’.
Pass ‘GUIX_DOWNLOAD_METHODS’ to #:env-vars.
* guix/cvs-download.scm (cvs-fetch)[build]: Honor ‘download-method-enabled?’.
Pass ‘GUIX_DOWNLOAD_METHODS’ to #:env-vars.
* guix/hg-download.scm (hg-fetch): Honor ‘download-method-enabled?’.
Pass #:env-vars to ‘gexp->derivation’.
* guix/scripts/perform-download.scm (perform-download): Honor
“download-methods” from DRV. Parameterize ‘%download-methods’ before
calling ‘url-fetch’.
(perform-git-download): Likewise.
* guix/svn-download.scm (svn-fetch): Honor ‘download-method-enabled?’.
Pass ‘GUIX_DOWNLOAD_METHODS’ to #:env-vars.
(svn-multi-fetch): Likewise.

Change-Id: Ia3402e17f0303dfa964bdc761265efe8a1dd69ab
---
guix/build/download.scm | 50 ++++++++++++++----
guix/build/git.scm | 15 ++++--
guix/bzr-download.scm | 28 ++++++----
guix/cvs-download.scm | 24 ++++++---
guix/download.scm | 53 +++++++------------
guix/git-download.scm | 20 +++----
guix/hg-download.scm | 36 ++++++++-----
guix/scripts/perform-download.scm | 70 +++++++++++++-----------
guix/svn-download.scm | 88 +++++++++++++++++++------------
9 files changed, 230 insertions(+), 154 deletions(-)

Toggle diff (386 lines)
diff --git a/guix/build/download.scm b/guix/build/download.scm
index db0a39084b..74b7486b7b 100644
--- a/guix/build/download.scm
+++ b/guix/build/download.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012-2022 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012-2022, 2024 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2015 Mark H Weaver <mhw@netris.org>
;;; Copyright © 2017 Tobias Geerinckx-Rice <me@tobias.gr>
;;; Copyright © 2021 Timothy Sample <samplet@ngyro.com>
@@ -40,7 +40,10 @@ (define-module (guix build download)
#:autoload (guix swh) (swh-download-directory %verify-swh-certificate?)
#:use-module (ice-9 match)
#:use-module (ice-9 format)
- #:export (open-socket-for-uri
+ #:export (%download-methods
+ download-method-enabled?
+
+ open-socket-for-uri
open-connection-for-uri
http-fetch
%x509-certificate-directory
@@ -622,6 +625,20 @@ (define-syntax-rule (false-if-exception* body ...)
(lambda (key . args)
(print-exception (current-error-port) #f key args))))
+(define %download-methods
+ ;; Either #f (the default) or a list of symbols denoting the sequence of
+ ;; download methods to be used--e.g., '(swh nar upstream).
+ (make-parameter
+ (and=> (getenv "GUIX_DOWNLOAD_METHODS")
+ (lambda (str)
+ (map string->symbol (string-tokenize str))))))
+
+(define (download-method-enabled? method)
+ "Return true if METHOD (a symbol such as 'swh) is enabled as part of the
+download fallback sequence."
+ (or (not (%download-methods))
+ (memq method (%download-methods))))
+
(define (uri-vicinity dir file)
"Concatenate DIR, slash, and FILE, keeping only one slash in between.
This is required by some HTTP servers."
@@ -788,18 +805,28 @@ (define* (url-fetch url file
hashes)))
disarchive-mirrors))
+ (define initial-uris
+ (append (if (download-method-enabled? 'upstream)
+ uri
+ '())
+ (if (download-method-enabled? 'content-addressed-mirrors)
+ content-addressed-uris
+ '())
+ (if (download-method-enabled? 'internet-archive)
+ (match uri
+ ((first . _)
+ (or (and=> (internet-archive-uri first) list)
+ '()))
+ (() '()))
+ '())))
+
;; Make this unbuffered so 'progress-report/file' works as expected. 'line
;; means '\n', not '\r', so it's not appropriate here.
(setvbuf (current-output-port) 'none)
(setvbuf (current-error-port) 'line)
- (let try ((uri (append uri content-addressed-uris
- (match uri
- ((first . _)
- (or (and=> (internet-archive-uri first) list)
- '()))
- (() '())))))
+ (let try ((uri initial-uris))
(match uri
((uri tail ...)
(or (fetch uri file)
@@ -807,9 +834,10 @@ (define* (url-fetch url file
(()
;; If we are looking for a software archive, one last thing we
;; can try is to use Disarchive to assemble it.
- (or (disarchive-fetch/any disarchive-uris file
- #:verify-certificate? verify-certificate?
- #:timeout timeout)
+ (or (and (download-method-enabled? 'disarchive)
+ (disarchive-fetch/any disarchive-uris file
+ #:verify-certificate? verify-certificate?
+ #:timeout timeout))
(begin
(format (current-error-port) "failed to download ~s from ~s~%"
file url)
diff --git a/guix/build/git.scm b/guix/build/git.scm
index a135026fae..62877394bb 100644
--- a/guix/build/git.scm
+++ b/guix/build/git.scm
@@ -19,6 +19,8 @@
(define-module (guix build git)
#:use-module (guix build utils)
+ #:use-module ((guix build download)
+ #:select (download-method-enabled?))
#:autoload (guix build download-nar) (download-nar)
#:autoload (guix swh) (%verify-swh-certificate?
swh-download
@@ -102,17 +104,20 @@ (define* (git-fetch-with-fallback url commit directory
When HASH and HASH-ALGORITHM are provided, they are interpreted as the nar
hash of the directory of interested and are used as its content address at
SWH."
- (or (git-fetch url commit directory
- #:lfs? lfs?
- #:recursive? recursive?
- #:git-command git-command)
- (download-nar item directory)
+ (or (and (download-method-enabled? 'upstream)
+ (git-fetch url commit directory
+ #:lfs? lfs?
+ #:recursive? recursive?
+ #:git-command git-command))
+ (and (download-method-enabled? 'nar)
+ (download-nar item directory))
;; As a last resort, attempt to download from Software Heritage.
;; Disable X.509 certificate verification to avoid depending
;; on nss-certs--we're authenticating the checkout anyway.
;; XXX: Currently recursive checkouts are not supported.
(and (not recursive?)
+ (download-method-enabled? 'swh)
(parameterize ((%verify-swh-certificate? #f))
(format (current-error-port)
"Trying to download from Software Heritage...~%")
diff --git a/guix/bzr-download.scm b/guix/bzr-download.scm
index 01c12fd54d..a22c9bee99 100644
--- a/guix/bzr-download.scm
+++ b/guix/bzr-download.scm
@@ -24,7 +24,7 @@ (define-module (guix bzr-download)
#:use-module (guix packages)
#:use-module (guix records)
#:use-module (guix store)
-
+ #:use-module (ice-9 match)
#:export (bzr-reference
bzr-reference?
bzr-reference-url
@@ -72,20 +72,26 @@ (define* (bzr-fetch ref hash-algo hash
(with-imported-modules (source-module-closure
'((guix build bzr)
(guix build utils)
+ (guix build download)
(guix build download-nar)))
#~(begin
(use-modules (guix build bzr)
(guix build download-nar)
+ ((guix build download)
+ #:select (download-method-enabled?))
(guix build utils)
(srfi srfi-34))
- (or (guard (c ((invoke-error? c)
- (report-invoke-error c)
- #f))
- (bzr-fetch (getenv "bzr url") (getenv "bzr reference")
- #$output
- #:bzr-command (string-append #+bzr "/bin/brz")))
- (download-nar #$output))))))
+ (or (and (download-method-enabled? 'upstream)
+ (guard (c ((invoke-error? c)
+ (report-invoke-error c)
+ #f))
+ (bzr-fetch (getenv "bzr url") (getenv "bzr reference")
+ #$output
+ #:bzr-command
+ (string-append #+bzr "/bin/brz"))))
+ (and (download-method-enabled? 'nar)
+ (download-nar #$output)))))))
(mlet %store-monad ((guile (package->derivation guile system)))
(gexp->derivation (or name "bzr-branch") build
@@ -95,7 +101,11 @@ (define* (bzr-fetch ref hash-algo hash
#:script-name "bzr-download"
#:env-vars
`(("bzr url" . ,(bzr-reference-url ref))
- ("bzr reference" . ,(bzr-reference-revision ref)))
+ ("bzr reference" . ,(bzr-reference-revision ref))
+ ,@(match (getenv "GUIX_DOWNLOAD_METHODS")
+ (#f '())
+ (value
+ `(("GUIX_DOWNLOAD_METHODS" . ,value)))))
#:leaked-env-vars '("http_proxy" "https_proxy"
"LC_ALL" "LC_MESSAGES" "LANG"
"COLUMNS")
diff --git a/guix/cvs-download.scm b/guix/cvs-download.scm
index c0c526b9db..023054941b 100644
--- a/guix/cvs-download.scm
+++ b/guix/cvs-download.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2014, 2015, 2016, 2017, 2019 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2014-2017, 2019, 2024 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2014 Sree Harsha Totakura <sreeharsha@totakura.in>
;;; Copyright © 2015 Mark H Weaver <mhw@netris.org>
;;;
@@ -73,6 +73,7 @@ (define* (cvs-fetch ref hash-algo hash
(define modules
(delete '(guix config)
(source-module-closure '((guix build cvs)
+ (guix build download)
(guix build download-nar)))))
(define build
(with-imported-modules modules
@@ -80,20 +81,29 @@ (define* (cvs-fetch ref hash-algo hash
guile-lzlib)
#~(begin
(use-modules (guix build cvs)
+ ((guix build download)
+ #:select (download-method-enabled?))
(guix build download-nar))
- (or (cvs-fetch '#$(cvs-reference-root-directory ref)
- '#$(cvs-reference-module ref)
- '#$(cvs-reference-revision ref)
- #$output
- #:cvs-command (string-append #+cvs "/bin/cvs"))
- (download-nar #$output))))))
+ (or (and (download-method-enabled? 'upstream)
+ (cvs-fetch '#$(cvs-reference-root-directory ref)
+ '#$(cvs-reference-module ref)
+ '#$(cvs-reference-revision ref)
+ #$output
+ #:cvs-command
+ #+(file-append cvs "/bin/cvs")))
+ (and (download-method-enabled? 'nar)
+ (download-nar #$output)))))))
(mlet %store-monad ((guile (package->derivation guile system)))
(gexp->derivation (or name "cvs-checkout") build
#:leaked-env-vars '("http_proxy" "https_proxy"
"LC_ALL" "LC_MESSAGES" "LANG"
"COLUMNS")
+ #:env-vars (match (getenv "GUIX_DOWNLOAD_METHODS")
+ (#f '())
+ (value
+ `(("GUIX_DOWNLOAD_METHODS" . ,value))))
#:system system
#:hash-algo hash-algo
#:hash hash
diff --git a/guix/download.scm b/guix/download.scm
index 21d02ab203..3dfe143e9f 100644
--- a/guix/download.scm
+++ b/guix/download.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012-2021, 2024 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2013, 2014, 2015 Andreas Enge <andreas@enge.fr>
;;; Copyright © 2015 Federico Beffa <beffa@fbengineering.ch>
;;; Copyright © 2016 Alex Griffin <a@ajgrf.com>
@@ -35,9 +35,9 @@ (define-module (guix download)
#:use-module (web uri)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-26)
- #:export (%mirrors
+ #:export (%download-methods
+ %mirrors
%disarchive-mirrors
- %download-fallback-test
(url-fetch* . url-fetch)
url-fetch/executable
url-fetch/tarbomb
@@ -434,10 +434,19 @@ (define %no-disarchive-mirrors-file
(define built-in-builders*
(store-lift built-in-builders))
+(define %download-methods
+ ;; Either #f (the default) or a list of symbols denoting the sequence of
+ ;; download methods to be used--e.g., '(swh nar upstream).
+ (make-parameter
+ (and=> (getenv "GUIX_DOWNLOAD_METHODS")
+ (lambda (str)
+ (map string->symbol (string-tokenize str))))))
+
(define* (built-in-download file-name url
#:key system hash-algo hash
mirrors content-addressed-mirrors
disarchive-mirrors
+ (download-methods (%download-methods))
executable?
(guile 'unused))
"Download FILE-NAME from URL using the built-in 'download' builder. When
@@ -471,6 +480,11 @@ (define* (built-in-download file-name url
("disarchive-mirrors" . ,disarchive-mirrors)
,@(if executable?
'(("executable" . "1"))
+ '())
+ ,@(if download-methods
+ `(("download-methods"
+ . ,(object->string
+ download-methods)))
'()))
;; Do not offload this derivation because we cannot be
@@ -479,24 +493,6 @@ (define* (built-in-download file-name url
;; for that built-in is widespread.
#:local-build? #t)))
-(define %download-fallback-test
- ;; Define whether to test one of the download fallback mechanism. Possible
- ;; values are:
- ;;
- ;; - #f, to use the normal download methods, not trying to exercise the
- ;; fallback mechanism;
- ;;
- ;; - 'none, to disable all the fallback mechanisms;
- ;;
- ;; - 'content-addressed-mirrors, to purposefully attempt to download from
- ;; a content-addressed mirror;
- ;;
- ;; - 'disarchive-mirrors, to download from Disarchive + Software Heritage.
- ;;
- ;; This is meant to be used for testing purposes.
- (make-parameter (and=> (getenv "GUIX_DOWNLOAD_FALLBACK_TEST")
- string->symbol)))
-
(define* (url-fetch* url hash-algo hash
#:optional name
#:key (system (%current-system))
@@ -532,10 +528,7 @@ (define* (url-fetch* url hash-algo hash
(unless (member "download" builtins)
(error "'guix-daemon' is too old, please upgrade" builtins))
- (built-in-download (or name file-name)
- (match (%download-fallback-test)
- ((or #f 'none) url)
- (_ "https://example.org/does-not-exist"))
+ (built-in-download (or name file-name) url
#:guile guile
#:system system
#:hash-algo hash-algo
@@ -543,15 +536,9 @@ (define* (url-fetch* url hash-algo hash
#:executable? executable?
#:mirrors %mirror-file
#:content-addressed-mirrors
- (match (%download-fallback-test)
- ((or #f 'content-addressed-mirrors)
- %content-addressed-mirror-file)
- (_ %no-mirrors-file))
+ %content-addressed-mirror-file
#:disarchive-mirrors
- (match (%download-fallback-test)
- ((or #f 'disarchive-mirrors)
- %disarchive-mirror-file)
- (_ %no-disarchive-mirrors-file)))))))
+ %disarchive-mirror-file)))))
(define* (url-fetch/executable url hash-algo hash
#:optional name
diff --git a/guix/git-download.scm b/guix/git-download.scm
index aadcbd234c..d26a814e07 100644
--- a/guix/git-download.scm
+++ b/guix/git-download.scm
@@ -29,8 +29,8 @@ (define-module (guix git-download)
#:use-module (guix packages)
#:use-module (guix modules)
#:use-module ((guix derivations) #:select (raw-derivation))
+ #:autoload (guix download) (%download-methods)
#:autoload (guix build-system gnu) (standard-packages)
- #:autoload (guix download) (%download-fallback-test)
#:autoload (git bindings) (libgit2-init!)
#:autoload (git repository) (repository-open
repository-close!
@@ -180,11 +180,7 @@ (define* (git-fetch/in-band* ref hash-algo hash
;; downloads.
#:script-name "git-download"
#:env-vars
- `(("git url" . ,(match (%download-fallback-test)
- ('content-addressed-mirrors
- "https://example.org/does-not-exist")
- (_
- (git-reference-url ref))))
+ `(("git url" . ,(git-reference-url ref))
("git commit" . ,(git-reference-commit ref))
("git recursive?" . ,(object->string
(git-reference-recursive? ref)))
@@ -246,14 +242,14 @@ (define* (git-fetch/built-in ref hash-algo hash
#:recursive
This message was truncated. Download the full message here.
S
S
Simon Tournier wrote on 7 Mar 19:38 +0100
Re: [bug#69328] [PATCH v2 00/12] Better source code recovery from SWH
877cidriol.fsf@gmail.com
Hi,

On mar., 05 mars 2024 at 12:06, Ludovic Courtès <ludo@gnu.org> wrote:

Toggle quote (15 lines)
> Ludovic Courtès (12):
> lint: Switch to SRFI-71.
> lint: archival: Fix crash in non-Git case.
> lint: archival: Trigger “Save Code Now” for VCSes other than Git.
> swh: Add ‘type’ field to <visit>.
> swh: ‘origin-visits’ takes an optional ‘max’ parameter.
> swh: ‘lookup-origin-revision’ handles branches pointing to
> directories.
> hg-download: Use ‘swh-download-directory-by-nar-hash’.
> svn-download: Use ‘swh-download-directory-by-nar-hash’.
> bzr-download: Implement nar fallback.
> download-nar: Distinguish ‘output’ and ‘item’ parameter.
> perform-download: Allow use of ‘download-nar’ for ‘--check’ builds.
> download: Honor ‘GUIX_DOWNLOAD_METHODS’ environment variable.

LGTM.

Unrelated things for later. :-)

1. About CVS, IIRC, there is only one package: gnu-standards. And it
changes barely. Why not fetch from FTP or else instead of CVS?

2. About the lookup, currently it is done item per item when it could be
done several at once – Timothy does that with PoG. This helps for the
rate limit. For instance if one uses “guix lint -c archival -m
manifest.scm”.

3. The option ’-m’ for “guix lint” seems missing.

These #2 and #3 would help third-party channels, IMHO.

Although, I am slowly working on some “guix swh” extension… but I have
been distraction by another extension “guix try-out”, then distracted by
another one “guix cite”. Well, I need to finish all my homeworks. ;-)

Anyway, really nice new features!

Cheers,
simon
L
L
Ludovic Courtès wrote on 9 Mar 19:51 +0100
(name . Simon Tournier)(address . zimon.toutoune@gmail.com)
87y1arz1aw.fsf@gnu.org
Hello,

Simon Tournier <zimon.toutoune@gmail.com> skribis:

Toggle quote (19 lines)
> On mar., 05 mars 2024 at 12:06, Ludovic Courtès <ludo@gnu.org> wrote:
>
>> Ludovic Courtès (12):
>> lint: Switch to SRFI-71.
>> lint: archival: Fix crash in non-Git case.
>> lint: archival: Trigger “Save Code Now” for VCSes other than Git.
>> swh: Add ‘type’ field to <visit>.
>> swh: ‘origin-visits’ takes an optional ‘max’ parameter.
>> swh: ‘lookup-origin-revision’ handles branches pointing to
>> directories.
>> hg-download: Use ‘swh-download-directory-by-nar-hash’.
>> svn-download: Use ‘swh-download-directory-by-nar-hash’.
>> bzr-download: Implement nar fallback.
>> download-nar: Distinguish ‘output’ and ‘item’ parameter.
>> perform-download: Allow use of ‘download-nar’ for ‘--check’ builds.
>> download: Honor ‘GUIX_DOWNLOAD_METHODS’ environment variable.
>
> LGTM.

Pushed as 2f441fc738976175d438f7942211b1894e2eb416, thank you & Timothy
for taking a look!

I’ll update the ‘guix’ package in the coming days so we can benefit from
all of this.

Toggle quote (5 lines)
> Unrelated things for later. :-)
>
> 1. About CVS, IIRC, there is only one package: gnu-standards. And it
> changes barely. Why not fetch from FTP or else instead of CVS?

Good idea (or maybe someday someone will finally migrate it to some
other VCS?).

Toggle quote (9 lines)
> 2. About the lookup, currently it is done item per item when it could be
> done several at once – Timothy does that with PoG. This helps for the
> rate limit. For instance if one uses “guix lint -c archival -m
> manifest.scm”.
>
> 3. The option ’-m’ for “guix lint” seems missing.
>
> These #2 and #3 would help third-party channels, IMHO.

All good ideas.

Toggle quote (4 lines)
> Although, I am slowly working on some “guix swh” extension… but I have
> been distraction by another extension “guix try-out”, then distracted by
> another one “guix cite”. Well, I need to finish all my homeworks. ;-)

Heh, sounds exciting!

Ludo’.
Closed
?
Your comment

This issue is archived.

To comment on this conversation send an email to 69328@debbugs.gnu.org

To respond to this issue using the mumi CLI, first switch to it
mumi current 69328
Then, you may apply the latest patchset in this issue (with sign off)
mumi am -- -s
Or, compose a reply to this issue
mumi compose
Or, send patches to this issue
mumi send-email *.patch