* [bug#69328] [PATCH 00/12] Better source code recovery from SWH
@ 2024-02-23 14:22 Ludovic Courtès
2024-02-23 15:48 ` [bug#69328] [PATCH 01/12] lint: Switch to SRFI-71 Ludovic Courtès
` (13 more replies)
0 siblings, 14 replies; 33+ messages in thread
From: Ludovic Courtès @ 2024-02-23 14:22 UTC (permalink / raw)
To: 69328
Cc: Ludovic Courtès, Christopher Baines, Josselin Poiret,
Ludovic Courtès, Mathieu Othacehe, Ricardo Wurmus,
Simon Tournier, Tobias Geerinckx-Rice
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.
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:
<https://gitlab.softwareheritage.org/swh/infra/sysadm-environment/-/issues/5256>.
• 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
^ permalink raw reply [flat|nested] 33+ messages in thread* [bug#69328] [PATCH 01/12] lint: Switch to SRFI-71. 2024-02-23 14:22 [bug#69328] [PATCH 00/12] Better source code recovery from SWH Ludovic Courtès @ 2024-02-23 15:48 ` Ludovic Courtès 2024-02-23 15:48 ` [bug#69328] [PATCH 02/12] lint: archival: Fix crash in non-Git case Ludovic Courtès ` (12 subsequent siblings) 13 siblings, 0 replies; 33+ messages in thread From: Ludovic Courtès @ 2024-02-23 15:48 UTC (permalink / raw) To: 69328 Cc: Ludovic Courtès, Christopher Baines, Josselin Poiret, Ludovic Courtès, Mathieu Othacehe, Ricardo Wurmus, Simon Tournier, Tobias Geerinckx-Rice * guix/lint.scm: Switch from SRFI-11 to SRFI-71. Change-Id: I62e6cd304ad73570bd12bd67f7051566205596bb --- guix/lint.scm | 9 ++++----- 1 file changed, 4 insertions(+), 5 deletions(-) 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 ^ permalink raw reply related [flat|nested] 33+ messages in thread
* [bug#69328] [PATCH 02/12] lint: archival: Fix crash in non-Git case. 2024-02-23 14:22 [bug#69328] [PATCH 00/12] Better source code recovery from SWH Ludovic Courtès 2024-02-23 15:48 ` [bug#69328] [PATCH 01/12] lint: Switch to SRFI-71 Ludovic Courtès @ 2024-02-23 15:48 ` Ludovic Courtès 2024-02-23 15:48 ` [bug#69328] [PATCH 03/12] lint: archival: Trigger “Save Code Now” for VCSes other than Git Ludovic Courtès ` (11 subsequent siblings) 13 siblings, 0 replies; 33+ messages in thread From: Ludovic Courtès @ 2024-02-23 15:48 UTC (permalink / raw) To: 69328 Cc: Ludovic Courtès, Christopher Baines, Josselin Poiret, Ludovic Courtès, Mathieu Othacehe, Ricardo Wurmus, Simon Tournier, Tobias Geerinckx-Rice 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(+) 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 ^ permalink raw reply related [flat|nested] 33+ messages in thread
* [bug#69328] [PATCH 03/12] lint: archival: Trigger “Save Code Now” for VCSes other than Git. 2024-02-23 14:22 [bug#69328] [PATCH 00/12] Better source code recovery from SWH Ludovic Courtès 2024-02-23 15:48 ` [bug#69328] [PATCH 01/12] lint: Switch to SRFI-71 Ludovic Courtès 2024-02-23 15:48 ` [bug#69328] [PATCH 02/12] lint: archival: Fix crash in non-Git case Ludovic Courtès @ 2024-02-23 15:48 ` Ludovic Courtès 2024-02-23 15:48 ` [bug#69328] [PATCH 04/12] swh: Add ‘type’ field to <visit> Ludovic Courtès ` (10 subsequent siblings) 13 siblings, 0 replies; 33+ messages in thread From: Ludovic Courtès @ 2024-02-23 15:48 UTC (permalink / raw) To: 69328 Cc: Ludovic Courtès, Christopher Baines, Josselin Poiret, Ludovic Courtès, Mathieu Othacehe, Ricardo Wurmus, Simon Tournier, Tobias Geerinckx-Rice 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(-) 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 ^ permalink raw reply related [flat|nested] 33+ messages in thread
* [bug#69328] [PATCH 04/12] swh: Add ‘type’ field to <visit>. 2024-02-23 14:22 [bug#69328] [PATCH 00/12] Better source code recovery from SWH Ludovic Courtès ` (2 preceding siblings ...) 2024-02-23 15:48 ` [bug#69328] [PATCH 03/12] lint: archival: Trigger “Save Code Now” for VCSes other than Git Ludovic Courtès @ 2024-02-23 15:48 ` Ludovic Courtès 2024-02-23 15:48 ` [bug#69328] [PATCH 05/12] swh: ‘origin-visits’ takes an optional ‘max’ parameter Ludovic Courtès ` (9 subsequent siblings) 13 siblings, 0 replies; 33+ messages in thread From: Ludovic Courtès @ 2024-02-23 15:48 UTC (permalink / raw) To: 69328 Cc: Ludovic Courtès, Christopher Baines, Josselin Poiret, Ludovic Courtès, Mathieu Othacehe, Ricardo Wurmus, Simon Tournier, Tobias Geerinckx-Rice * guix/swh.scm (<visit>)[type]: New field. Change-Id: I7677984c7daef38d8f3c3bef19723fa0efb035ba --- guix/swh.scm | 2 ++ 1 file changed, 2 insertions(+) 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 ^ permalink raw reply related [flat|nested] 33+ messages in thread
* [bug#69328] [PATCH 05/12] swh: ‘origin-visits’ takes an optional ‘max’ parameter. 2024-02-23 14:22 [bug#69328] [PATCH 00/12] Better source code recovery from SWH Ludovic Courtès ` (3 preceding siblings ...) 2024-02-23 15:48 ` [bug#69328] [PATCH 04/12] swh: Add ‘type’ field to <visit> Ludovic Courtès @ 2024-02-23 15:48 ` Ludovic Courtès 2024-02-23 15:48 ` [bug#69328] [PATCH 06/12] swh: ‘lookup-origin-revision’ handles branches pointing to directories Ludovic Courtès ` (8 subsequent siblings) 13 siblings, 0 replies; 33+ messages in thread From: Ludovic Courtès @ 2024-02-23 15:48 UTC (permalink / raw) To: 69328 Cc: Ludovic Courtès, Christopher Baines, Josselin Poiret, Ludovic Courtès, Mathieu Othacehe, Ricardo Wurmus, Simon Tournier, Tobias Geerinckx-Rice * 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(-) 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 ^ permalink raw reply related [flat|nested] 33+ messages in thread
* [bug#69328] [PATCH 06/12] swh: ‘lookup-origin-revision’ handles branches pointing to directories. 2024-02-23 14:22 [bug#69328] [PATCH 00/12] Better source code recovery from SWH Ludovic Courtès ` (4 preceding siblings ...) 2024-02-23 15:48 ` [bug#69328] [PATCH 05/12] swh: ‘origin-visits’ takes an optional ‘max’ parameter Ludovic Courtès @ 2024-02-23 15:48 ` Ludovic Courtès 2024-02-23 15:48 ` [bug#69328] [PATCH 07/12] hg-download: Use ‘swh-download-directory-by-nar-hash’ Ludovic Courtès ` (7 subsequent siblings) 13 siblings, 0 replies; 33+ messages in thread From: Ludovic Courtès @ 2024-02-23 15:48 UTC (permalink / raw) To: 69328 Cc: Ludovic Courtès, Christopher Baines, Josselin Poiret, Ludovic Courtès, Mathieu Othacehe, Ricardo Wurmus, Simon Tournier, Tobias Geerinckx-Rice Fixes <https://issues.guix.gnu.org/69070>. * 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(-) 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 ^ permalink raw reply related [flat|nested] 33+ messages in thread
* [bug#69328] [PATCH 07/12] hg-download: Use ‘swh-download-directory-by-nar-hash’. 2024-02-23 14:22 [bug#69328] [PATCH 00/12] Better source code recovery from SWH Ludovic Courtès ` (5 preceding siblings ...) 2024-02-23 15:48 ` [bug#69328] [PATCH 06/12] swh: ‘lookup-origin-revision’ handles branches pointing to directories Ludovic Courtès @ 2024-02-23 15:48 ` Ludovic Courtès 2024-02-23 15:48 ` [bug#69328] [PATCH 08/12] svn-download: " Ludovic Courtès ` (6 subsequent siblings) 13 siblings, 0 replies; 33+ messages in thread From: Ludovic Courtès @ 2024-02-23 15:48 UTC (permalink / raw) To: 69328 Cc: Ludovic Courtès, Christopher Baines, Josselin Poiret, Ludovic Courtès, Mathieu Othacehe, Ricardo Wurmus, Simon Tournier, Tobias Geerinckx-Rice 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(-) 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 ^ permalink raw reply related [flat|nested] 33+ messages in thread
* [bug#69328] [PATCH 08/12] svn-download: Use ‘swh-download-directory-by-nar-hash’. 2024-02-23 14:22 [bug#69328] [PATCH 00/12] Better source code recovery from SWH Ludovic Courtès ` (6 preceding siblings ...) 2024-02-23 15:48 ` [bug#69328] [PATCH 07/12] hg-download: Use ‘swh-download-directory-by-nar-hash’ Ludovic Courtès @ 2024-02-23 15:48 ` Ludovic Courtès 2024-02-23 15:48 ` [bug#69328] [PATCH 09/12] bzr-download: Implement nar fallback Ludovic Courtès ` (5 subsequent siblings) 13 siblings, 0 replies; 33+ messages in thread From: Ludovic Courtès @ 2024-02-23 15:48 UTC (permalink / raw) To: 69328 Cc: Ludovic Courtès, Christopher Baines, Josselin Poiret, Ludovic Courtès, Mathieu Othacehe, Ricardo Wurmus, Simon Tournier, Tobias Geerinckx-Rice Fixes <https://issues.guix.gnu.org/43442>. * 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(-) 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 ^ permalink raw reply related [flat|nested] 33+ messages in thread
* [bug#69328] [PATCH 09/12] bzr-download: Implement nar fallback. 2024-02-23 14:22 [bug#69328] [PATCH 00/12] Better source code recovery from SWH Ludovic Courtès ` (7 preceding siblings ...) 2024-02-23 15:48 ` [bug#69328] [PATCH 08/12] svn-download: " Ludovic Courtès @ 2024-02-23 15:48 ` Ludovic Courtès 2024-02-23 15:48 ` [bug#69328] [PATCH 10/12] download-nar: Distinguish ‘output’ and ‘item’ parameter Ludovic Courtès ` (4 subsequent siblings) 13 siblings, 0 replies; 33+ messages in thread From: Ludovic Courtès @ 2024-02-23 15:48 UTC (permalink / raw) To: 69328 Cc: Ludovic Courtès, Christopher Baines, Josselin Poiret, Ludovic Courtès, Mathieu Othacehe, Ricardo Wurmus, Simon Tournier, Tobias Geerinckx-Rice * 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(-) 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 ^ permalink raw reply related [flat|nested] 33+ messages in thread
* [bug#69328] [PATCH 10/12] download-nar: Distinguish ‘output’ and ‘item’ parameter. 2024-02-23 14:22 [bug#69328] [PATCH 00/12] Better source code recovery from SWH Ludovic Courtès ` (8 preceding siblings ...) 2024-02-23 15:48 ` [bug#69328] [PATCH 09/12] bzr-download: Implement nar fallback Ludovic Courtès @ 2024-02-23 15:48 ` Ludovic Courtès 2024-02-23 15:48 ` [bug#69328] [PATCH 11/12] perform-download: Allow use of ‘download-nar’ for ‘--check’ builds Ludovic Courtès ` (3 subsequent siblings) 13 siblings, 0 replies; 33+ messages in thread From: Ludovic Courtès @ 2024-02-23 15:48 UTC (permalink / raw) To: 69328; +Cc: Ludovic Courtès 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(-) 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 ^ permalink raw reply related [flat|nested] 33+ messages in thread
* [bug#69328] [PATCH 11/12] perform-download: Allow use of ‘download-nar’ for ‘--check’ builds. 2024-02-23 14:22 [bug#69328] [PATCH 00/12] Better source code recovery from SWH Ludovic Courtès ` (9 preceding siblings ...) 2024-02-23 15:48 ` [bug#69328] [PATCH 10/12] download-nar: Distinguish ‘output’ and ‘item’ parameter Ludovic Courtès @ 2024-02-23 15:48 ` Ludovic Courtès 2024-02-23 15:48 ` [bug#69328] [PATCH 12/12] download: Honor ‘GUIX_DOWNLOAD_SEQUENCE’ environment variable Ludovic Courtès ` (2 subsequent siblings) 13 siblings, 0 replies; 33+ messages in thread From: Ludovic Courtès @ 2024-02-23 15:48 UTC (permalink / raw) To: 69328 Cc: Ludovic Courtès, Christopher Baines, Josselin Poiret, Ludovic Courtès, Mathieu Othacehe, Ricardo Wurmus, Simon Tournier, Tobias Geerinckx-Rice 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(-) 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 ^ permalink raw reply related [flat|nested] 33+ messages in thread
* [bug#69328] [PATCH 12/12] download: Honor ‘GUIX_DOWNLOAD_SEQUENCE’ environment variable. 2024-02-23 14:22 [bug#69328] [PATCH 00/12] Better source code recovery from SWH Ludovic Courtès ` (10 preceding siblings ...) 2024-02-23 15:48 ` [bug#69328] [PATCH 11/12] perform-download: Allow use of ‘download-nar’ for ‘--check’ builds Ludovic Courtès @ 2024-02-23 15:48 ` Ludovic Courtès 2024-03-03 4:53 ` Timothy Sample 2024-02-23 15:53 ` [bug#69328] [PATCH 00/12] Better source code recovery from SWH Ludovic Courtès 2024-03-03 4:54 ` Timothy Sample 13 siblings, 1 reply; 33+ messages in thread From: Ludovic Courtès @ 2024-02-23 15:48 UTC (permalink / raw) To: 69328 Cc: Ludovic Courtès, Christopher Baines, Josselin Poiret, Ludovic Courtès, Mathieu Othacehe, Ricardo Wurmus, Simon Tournier, Tobias Geerinckx-Rice 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(-) 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-algo hash #:recursive? #t #:env-vars `(("url" . ,(object->string - (match (%download-fallback-test) - ('content-addressed-mirrors - "https://example.org/does-not-exist") - (_ - (git-reference-url ref))))) + (git-reference-url ref))) ("commit" . ,(git-reference-commit ref)) ("recursive?" . ,(object->string - (git-reference-recursive? ref)))) + (git-reference-recursive? ref))) + ,@(if (%download-sequence) + `(("download-sequence" + . ,(object->string (%download-sequence)))) + '())) #:leaked-env-vars '("http_proxy" "https_proxy" "LC_ALL" "LC_MESSAGES" "LANG" "COLUMNS") diff --git a/guix/hg-download.scm b/guix/hg-download.scm index dd28d9c244..d49732ba63 100644 --- a/guix/hg-download.scm +++ b/guix/hg-download.scm @@ -84,6 +84,7 @@ (define* (hg-fetch ref hash-algo hash (define modules (delete '(guix config) (source-module-closure '((guix build hg) + (guix build download) (guix build download-nar) (guix swh))))) @@ -94,6 +95,8 @@ (define* (hg-fetch ref hash-algo hash #~(begin (use-modules (guix build hg) (guix build utils) ;for `set-path-environment-variable' + ((guix build download) + #:select (download-method-enabled?)) (guix build download-nar) (guix swh) (ice-9 match)) @@ -106,28 +109,35 @@ (define* (hg-fetch ref hash-algo hash (setvbuf (current-output-port) 'line) (setvbuf (current-error-port) 'line) - (or (hg-fetch '#$(hg-reference-url ref) - '#$(hg-reference-changeset ref) - #$output - #:hg-command (string-append #+hg "/bin/hg")) - (download-nar #$output) + (or (and (download-method-enabled? 'upstream) + (hg-fetch '#$(hg-reference-url ref) + '#$(hg-reference-changeset ref) + #$output + #:hg-command (string-append #+hg "/bin/hg"))) + (and (download-method-enabled? 'nar) + (download-nar #$output)) ;; 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. - (parameterize ((%verify-swh-certificate? #f)) - (format (current-error-port) - "Trying to download from Software Heritage...~%") - (or (swh-download-directory-by-nar-hash #$hash '#$hash-algo - #$output) - (swh-download #$(hg-reference-url ref) - #$(hg-reference-changeset ref) - #$output)))))))) + (and (download-method-enabled? 'swh) + (parameterize ((%verify-swh-certificate? #f)) + (format (current-error-port) + "Trying to download from Software Heritage...~%") + (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 #: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 #:local-build? #t ;don't offload repo cloning #:hash-algo hash-algo 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 @@ -21,7 +21,7 @@ (define-module (guix scripts perform-download) #:use-module (guix scripts) #:use-module (guix derivations) #:use-module ((guix store) #:select (derivation-path? store-path?)) - #:autoload (guix build download) (url-fetch) + #:autoload (guix build download) (%download-sequence url-fetch) #:autoload (guix build git) (git-fetch-with-fallback) #:autoload (guix config) (%git) #:use-module (ice-9 match) @@ -55,7 +55,8 @@ (define* (perform-download drv output (executable "executable") (mirrors "mirrors") (content-addressed-mirrors "content-addressed-mirrors") - (disarchive-mirrors "disarchive-mirrors")) + (disarchive-mirrors "disarchive-mirrors") + (download-sequence "download-sequence")) (unless url (leave (G_ "~a: missing URL~%") (derivation-file-name drv))) @@ -64,26 +65,30 @@ (define* (perform-download drv output (algo (derivation-output-hash-algo drv-output)) (hash (derivation-output-hash drv-output))) ;; We're invoked by the daemon, which gives us write access to OUTPUT. - (when (url-fetch url output - #:print-build-trace? print-build-trace? - #:mirrors (if mirrors - (call-with-input-file mirrors read) - '()) - #:content-addressed-mirrors - (if content-addressed-mirrors - (call-with-input-file content-addressed-mirrors - (lambda (port) - (eval (read port) %user-module))) - '()) - #:disarchive-mirrors - (if disarchive-mirrors - (call-with-input-file disarchive-mirrors read) - '()) - #:hashes `((,algo . ,hash)) + (when (parameterize ((%download-sequence + (and download-sequence + (call-with-input-string download-sequence + read)))) + (url-fetch url output + #:print-build-trace? print-build-trace? + #:mirrors (if mirrors + (call-with-input-file mirrors read) + '()) + #:content-addressed-mirrors + (if content-addressed-mirrors + (call-with-input-file content-addressed-mirrors + (lambda (port) + (eval (read port) %user-module))) + '()) + #:disarchive-mirrors + (if disarchive-mirrors + (call-with-input-file disarchive-mirrors read) + '()) + #:hashes `((,algo . ,hash)) - ;; Since DRV's output hash is known, X.509 certificate - ;; validation is pointless. - #:verify-certificate? #f) + ;; Since DRV's output hash is known, X.509 certificate + ;; validation is pointless. + #:verify-certificate? #f)) (when (and executable (string=? executable "1")) (chmod output #o755)))))) @@ -96,7 +101,8 @@ (define* (perform-git-download drv output 'bmRepair' builds." (derivation-let drv ((url "url") (commit "commit") - (recursive? "recursive?")) + (recursive? "recursive?") + (download-sequence "download-sequence")) (unless url (leave (G_ "~a: missing Git URL~%") (derivation-file-name drv))) (unless commit @@ -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))))) (define (assert-low-privileges) (when (zero? (getuid)) diff --git a/guix/svn-download.scm b/guix/svn-download.scm index ed1379a09e..beac7d34e3 100644 --- a/guix/svn-download.scm +++ b/guix/svn-download.scm @@ -93,6 +93,7 @@ (define* (svn-fetch ref hash-algo hash (define build (with-imported-modules (source-module-closure '((guix build svn) + (guix build download) (guix build download-nar) (guix build utils) (guix swh))) @@ -100,23 +101,28 @@ (define* (svn-fetch ref hash-algo hash guile-lzlib) #~(begin (use-modules (guix build svn) + ((guix build download) + #:select (download-method-enabled?)) (guix build download-nar) (guix swh) (ice-9 match)) - (or (svn-fetch (getenv "svn url") - (string->number (getenv "svn revision")) - #$output - #:svn-command #+(file-append svn "/bin/svn") - #:recursive? (match (getenv "svn recursive?") - ("yes" #t) - (_ #f)) - #:user-name (getenv "svn user name") - #:password (getenv "svn password")) - (download-nar #$output) - (parameterize ((%verify-swh-certificate? #f)) - (swh-download-directory-by-nar-hash #$hash '#$hash-algo - #$output))))))) + (or (and (download-method-enabled? 'upstream) + (svn-fetch (getenv "svn url") + (string->number (getenv "svn revision")) + #$output + #:svn-command #+(file-append svn "/bin/svn") + #:recursive? (match (getenv "svn recursive?") + ("yes" #t) + (_ #f)) + #:user-name (getenv "svn user name") + #:password (getenv "svn password"))) + (and (download-method-enabled? 'nar) + (download-nar #$output)) + (and (download-method-enabled? 'swh) + (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 @@ -139,7 +145,11 @@ (define* (svn-fetch ref hash-algo hash ,@(if (svn-reference-password ref) `(("svn password" . ,(svn-reference-password ref))) - '())) + '()) + ,@(match (getenv "GUIX_DOWNLOAD_SEQUENCE") + (#f '()) + (value + `(("GUIX_DOWNLOAD_SEQUENCE" . ,value))))) #:system system #:hash-algo hash-algo @@ -178,6 +188,7 @@ (define* (svn-multi-fetch ref hash-algo hash (define build (with-imported-modules (source-module-closure '((guix build svn) + (guix build download) (guix build download-nar) (guix build utils) (guix swh))) @@ -186,6 +197,8 @@ (define* (svn-multi-fetch ref hash-algo hash #~(begin (use-modules (guix build svn) (guix build utils) + ((guix build download) + #:select (download-method-enabled?)) (guix build download-nar) (guix swh) (srfi srfi-1) @@ -197,26 +210,29 @@ (define* (svn-multi-fetch ref hash-algo hash ;; single file. (unless (string-suffix? "/" location) (mkdir-p (string-append #$output "/" (dirname location)))) - (svn-fetch (string-append (getenv "svn url") "/" location) - (string->number (getenv "svn revision")) - (if (string-suffix? "/" location) - (string-append #$output "/" location) - (string-append #$output "/" (dirname location))) - #:svn-command #+(file-append svn "/bin/svn") - #:recursive? (match (getenv "svn recursive?") - ("yes" #t) - (_ #f)) - #:user-name (getenv "svn user name") - #:password (getenv "svn password"))) + (and (download-method-enabled? 'upstream) + (svn-fetch (string-append (getenv "svn url") "/" location) + (string->number (getenv "svn revision")) + (if (string-suffix? "/" location) + (string-append #$output "/" location) + (string-append #$output "/" (dirname location))) + #:svn-command #+(file-append svn "/bin/svn") + #:recursive? (match (getenv "svn recursive?") + ("yes" #t) + (_ #f)) + #:user-name (getenv "svn user name") + #:password (getenv "svn password")))) (call-with-input-string (getenv "svn locations") read)) (begin (when (file-exists? #$output) (delete-file-recursively #$output)) - (or (download-nar #$output) - (parameterize ((%verify-swh-certificate? #f)) - (swh-download-directory-by-nar-hash - #$hash '#$hash-algo #$output))))))))) + (or (and (download-method-enabled? 'nar) + (download-nar #$output)) + (and (download-method-enabled? 'swh) + (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 @@ -241,7 +257,11 @@ (define* (svn-multi-fetch ref hash-algo hash ,@(if (svn-multi-reference-password ref) `(("svn password" . ,(svn-multi-reference-password ref))) - '())) + '()) + ,@(match (getenv "GUIX_DOWNLOAD_SEQUENCE") + (#f '()) + (value + `(("GUIX_DOWNLOAD_SEQUENCE" . ,value))))) #:leaked-env-vars '("http_proxy" "https_proxy" "LC_ALL" "LC_MESSAGES" "LANG" -- 2.41.0 ^ permalink raw reply related [flat|nested] 33+ messages in thread
* [bug#69328] [PATCH 12/12] download: Honor ‘GUIX_DOWNLOAD_SEQUENCE’ environment variable. 2024-02-23 15:48 ` [bug#69328] [PATCH 12/12] download: Honor ‘GUIX_DOWNLOAD_SEQUENCE’ environment variable Ludovic Courtès @ 2024-03-03 4:53 ` Timothy Sample 2024-03-05 10:26 ` Ludovic Courtès 0 siblings, 1 reply; 33+ messages in thread From: Timothy Sample @ 2024-03-03 4:53 UTC (permalink / raw) To: Ludovic Courtès Cc: Josselin Poiret, Tobias Geerinckx-Rice, Simon Tournier, Mathieu Othacehe, 69328, Ricardo Wurmus, Christopher Baines 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? ^ permalink raw reply [flat|nested] 33+ messages in thread
* [bug#69328] [PATCH 12/12] download: Honor ‘GUIX_DOWNLOAD_SEQUENCE’ environment variable. 2024-03-03 4:53 ` Timothy Sample @ 2024-03-05 10:26 ` Ludovic Courtès 0 siblings, 0 replies; 33+ messages in thread From: Ludovic Courtès @ 2024-03-05 10:26 UTC (permalink / raw) To: Timothy Sample Cc: Josselin Poiret, 69328, Simon Tournier, Mathieu Othacehe, Tobias Geerinckx-Rice, Ricardo Wurmus, Christopher Baines Timothy Sample <samplet@ngyro.com> skribis: > 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! ^ permalink raw reply [flat|nested] 33+ messages in thread
* [bug#69328] [PATCH 00/12] Better source code recovery from SWH 2024-02-23 14:22 [bug#69328] [PATCH 00/12] Better source code recovery from SWH Ludovic Courtès ` (11 preceding siblings ...) 2024-02-23 15:48 ` [bug#69328] [PATCH 12/12] download: Honor ‘GUIX_DOWNLOAD_SEQUENCE’ environment variable Ludovic Courtès @ 2024-02-23 15:53 ` Ludovic Courtès 2024-03-03 4:54 ` Timothy Sample 13 siblings, 0 replies; 33+ messages in thread From: Ludovic Courtès @ 2024-02-23 15:53 UTC (permalink / raw) To: 69328; +Cc: Timothy Sample I forgot to Cc: you Timothy, but you may have useful feedback to give on this series: <https://issues.guix.gnu.org/69328>. (Should we create a ‘source-code-archival’ team?) ^ permalink raw reply [flat|nested] 33+ messages in thread
* [bug#69328] [PATCH 00/12] Better source code recovery from SWH 2024-02-23 14:22 [bug#69328] [PATCH 00/12] Better source code recovery from SWH Ludovic Courtès ` (12 preceding siblings ...) 2024-02-23 15:53 ` [bug#69328] [PATCH 00/12] Better source code recovery from SWH Ludovic Courtès @ 2024-03-03 4:54 ` Timothy Sample 2024-03-05 10:58 ` Ludovic Courtès 13 siblings, 1 reply; 33+ messages in thread From: Timothy Sample @ 2024-03-03 4:54 UTC (permalink / raw) To: Ludovic Courtès Cc: Josselin Poiret, Tobias Geerinckx-Rice, Simon Tournier, Mathieu Othacehe, 69328, Ricardo Wurmus, Christopher Baines Ludovic Courtès <ludo@gnu.org> writes: > 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? > 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. > Feedback welcome! Other than the name and the little separate comment on the last patch, this all LGTM. -- Tim ^ permalink raw reply [flat|nested] 33+ messages in thread
* [bug#69328] [PATCH 00/12] Better source code recovery from SWH 2024-03-03 4:54 ` Timothy Sample @ 2024-03-05 10:58 ` Ludovic Courtès 2024-03-05 11:06 ` [bug#69328] [PATCH v2 " Ludovic Courtès ` (12 more replies) 0 siblings, 13 replies; 33+ messages in thread From: Ludovic Courtès @ 2024-03-05 10:58 UTC (permalink / raw) To: Timothy Sample Cc: Josselin Poiret, 69328, Simon Tournier, Mathieu Othacehe, Tobias Geerinckx-Rice, Ricardo Wurmus, Christopher Baines Hi, Timothy Sample <samplet@ngyro.com> skribis: > Ludovic Courtès <ludo@gnu.org> writes: [...] >> • 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”. > 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’. ^ permalink raw reply [flat|nested] 33+ messages in thread
* [bug#69328] [PATCH v2 00/12] Better source code recovery from SWH 2024-03-05 10:58 ` Ludovic Courtès @ 2024-03-05 11:06 ` Ludovic Courtès 2024-03-07 18:38 ` Simon Tournier 2024-03-05 11:06 ` [bug#69328] [PATCH v2 01/12] lint: Switch to SRFI-71 Ludovic Courtès ` (11 subsequent siblings) 12 siblings, 1 reply; 33+ messages in thread From: Ludovic Courtès @ 2024-03-05 11:06 UTC (permalink / raw) To: 69328 Cc: Timothy Sample, Ludovic Courtès, Christopher Baines, Josselin Poiret, Ludovic Courtès, Mathieu Othacehe, Ricardo Wurmus, Simon Tournier, Tobias Geerinckx-Rice 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 ^ permalink raw reply [flat|nested] 33+ messages in thread
* [bug#69328] [PATCH v2 00/12] Better source code recovery from SWH 2024-03-05 11:06 ` [bug#69328] [PATCH v2 " Ludovic Courtès @ 2024-03-07 18:38 ` Simon Tournier 2024-03-09 18:51 ` bug#69328: " Ludovic Courtès 0 siblings, 1 reply; 33+ messages in thread From: Simon Tournier @ 2024-03-07 18:38 UTC (permalink / raw) To: Ludovic Courtès, 69328 Cc: Timothy Sample, Josselin Poiret, Mathieu Othacehe, Ludovic Courtès, Tobias Geerinckx-Rice, Ricardo Wurmus, Christopher Baines Hi, 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. 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 ^ permalink raw reply [flat|nested] 33+ messages in thread
* bug#69328: [PATCH v2 00/12] Better source code recovery from SWH 2024-03-07 18:38 ` Simon Tournier @ 2024-03-09 18:51 ` Ludovic Courtès 0 siblings, 0 replies; 33+ messages in thread From: Ludovic Courtès @ 2024-03-09 18:51 UTC (permalink / raw) To: Simon Tournier Cc: Timothy Sample, Josselin Poiret, Mathieu Othacehe, Tobias Geerinckx-Rice, 69328-done, Ricardo Wurmus, Christopher Baines Hello, Simon Tournier <zimon.toutoune@gmail.com> skribis: > 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. > 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?). > 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. > 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’. ^ permalink raw reply [flat|nested] 33+ messages in thread
* [bug#69328] [PATCH v2 01/12] lint: Switch to SRFI-71. 2024-03-05 10:58 ` Ludovic Courtès 2024-03-05 11:06 ` [bug#69328] [PATCH v2 " Ludovic Courtès @ 2024-03-05 11:06 ` Ludovic Courtès 2024-03-05 11:06 ` [bug#69328] [PATCH v2 02/12] lint: archival: Fix crash in non-Git case Ludovic Courtès ` (10 subsequent siblings) 12 siblings, 0 replies; 33+ messages in thread From: Ludovic Courtès @ 2024-03-05 11:06 UTC (permalink / raw) To: 69328 Cc: Timothy Sample, Ludovic Courtès, Christopher Baines, Josselin Poiret, Ludovic Courtès, Mathieu Othacehe, Ricardo Wurmus, Simon Tournier, Tobias Geerinckx-Rice * guix/lint.scm: Switch from SRFI-11 to SRFI-71. Change-Id: I62e6cd304ad73570bd12bd67f7051566205596bb --- guix/lint.scm | 9 ++++----- 1 file changed, 4 insertions(+), 5 deletions(-) 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 ^ permalink raw reply related [flat|nested] 33+ messages in thread
* [bug#69328] [PATCH v2 02/12] lint: archival: Fix crash in non-Git case. 2024-03-05 10:58 ` Ludovic Courtès 2024-03-05 11:06 ` [bug#69328] [PATCH v2 " Ludovic Courtès 2024-03-05 11:06 ` [bug#69328] [PATCH v2 01/12] lint: Switch to SRFI-71 Ludovic Courtès @ 2024-03-05 11:06 ` Ludovic Courtès 2024-03-05 11:06 ` [bug#69328] [PATCH v2 03/12] lint: archival: Trigger “Save Code Now” for VCSes other than Git Ludovic Courtès ` (9 subsequent siblings) 12 siblings, 0 replies; 33+ messages in thread From: Ludovic Courtès @ 2024-03-05 11:06 UTC (permalink / raw) To: 69328 Cc: Timothy Sample, Ludovic Courtès, Christopher Baines, Josselin Poiret, Ludovic Courtès, Mathieu Othacehe, Ricardo Wurmus, Simon Tournier, Tobias Geerinckx-Rice 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(+) 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 ^ permalink raw reply related [flat|nested] 33+ messages in thread
* [bug#69328] [PATCH v2 03/12] lint: archival: Trigger “Save Code Now” for VCSes other than Git. 2024-03-05 10:58 ` Ludovic Courtès ` (2 preceding siblings ...) 2024-03-05 11:06 ` [bug#69328] [PATCH v2 02/12] lint: archival: Fix crash in non-Git case Ludovic Courtès @ 2024-03-05 11:06 ` Ludovic Courtès 2024-03-05 11:06 ` [bug#69328] [PATCH v2 04/12] swh: Add ‘type’ field to <visit> Ludovic Courtès ` (8 subsequent siblings) 12 siblings, 0 replies; 33+ messages in thread From: Ludovic Courtès @ 2024-03-05 11:06 UTC (permalink / raw) To: 69328 Cc: Timothy Sample, Ludovic Courtès, Christopher Baines, Josselin Poiret, Ludovic Courtès, Mathieu Othacehe, Ricardo Wurmus, Simon Tournier, Tobias Geerinckx-Rice 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(-) 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 ^ permalink raw reply related [flat|nested] 33+ messages in thread
* [bug#69328] [PATCH v2 04/12] swh: Add ‘type’ field to <visit>. 2024-03-05 10:58 ` Ludovic Courtès ` (3 preceding siblings ...) 2024-03-05 11:06 ` [bug#69328] [PATCH v2 03/12] lint: archival: Trigger “Save Code Now” for VCSes other than Git Ludovic Courtès @ 2024-03-05 11:06 ` Ludovic Courtès 2024-03-05 11:06 ` [bug#69328] [PATCH v2 05/12] swh: ‘origin-visits’ takes an optional ‘max’ parameter Ludovic Courtès ` (7 subsequent siblings) 12 siblings, 0 replies; 33+ messages in thread From: Ludovic Courtès @ 2024-03-05 11:06 UTC (permalink / raw) To: 69328 Cc: Timothy Sample, Ludovic Courtès, Christopher Baines, Josselin Poiret, Ludovic Courtès, Mathieu Othacehe, Ricardo Wurmus, Simon Tournier, Tobias Geerinckx-Rice * guix/swh.scm (<visit>)[type]: New field. Change-Id: I7677984c7daef38d8f3c3bef19723fa0efb035ba --- guix/swh.scm | 2 ++ 1 file changed, 2 insertions(+) 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 ^ permalink raw reply related [flat|nested] 33+ messages in thread
* [bug#69328] [PATCH v2 05/12] swh: ‘origin-visits’ takes an optional ‘max’ parameter. 2024-03-05 10:58 ` Ludovic Courtès ` (4 preceding siblings ...) 2024-03-05 11:06 ` [bug#69328] [PATCH v2 04/12] swh: Add ‘type’ field to <visit> Ludovic Courtès @ 2024-03-05 11:06 ` Ludovic Courtès 2024-03-05 11:06 ` [bug#69328] [PATCH v2 06/12] swh: ‘lookup-origin-revision’ handles branches pointing to directories Ludovic Courtès ` (6 subsequent siblings) 12 siblings, 0 replies; 33+ messages in thread From: Ludovic Courtès @ 2024-03-05 11:06 UTC (permalink / raw) To: 69328 Cc: Timothy Sample, Ludovic Courtès, Christopher Baines, Josselin Poiret, Ludovic Courtès, Mathieu Othacehe, Ricardo Wurmus, Simon Tournier, Tobias Geerinckx-Rice * 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(-) 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 ^ permalink raw reply related [flat|nested] 33+ messages in thread
* [bug#69328] [PATCH v2 06/12] swh: ‘lookup-origin-revision’ handles branches pointing to directories. 2024-03-05 10:58 ` Ludovic Courtès ` (5 preceding siblings ...) 2024-03-05 11:06 ` [bug#69328] [PATCH v2 05/12] swh: ‘origin-visits’ takes an optional ‘max’ parameter Ludovic Courtès @ 2024-03-05 11:06 ` Ludovic Courtès 2024-03-05 11:06 ` [bug#69328] [PATCH v2 07/12] hg-download: Use ‘swh-download-directory-by-nar-hash’ Ludovic Courtès ` (5 subsequent siblings) 12 siblings, 0 replies; 33+ messages in thread From: Ludovic Courtès @ 2024-03-05 11:06 UTC (permalink / raw) To: 69328 Cc: Timothy Sample, Ludovic Courtès, Christopher Baines, Josselin Poiret, Ludovic Courtès, Mathieu Othacehe, Ricardo Wurmus, Simon Tournier, Tobias Geerinckx-Rice Fixes <https://issues.guix.gnu.org/69070>. * 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(-) 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 ^ permalink raw reply related [flat|nested] 33+ messages in thread
* [bug#69328] [PATCH v2 07/12] hg-download: Use ‘swh-download-directory-by-nar-hash’. 2024-03-05 10:58 ` Ludovic Courtès ` (6 preceding siblings ...) 2024-03-05 11:06 ` [bug#69328] [PATCH v2 06/12] swh: ‘lookup-origin-revision’ handles branches pointing to directories Ludovic Courtès @ 2024-03-05 11:06 ` Ludovic Courtès 2024-03-05 11:06 ` [bug#69328] [PATCH v2 08/12] svn-download: " Ludovic Courtès ` (4 subsequent siblings) 12 siblings, 0 replies; 33+ messages in thread From: Ludovic Courtès @ 2024-03-05 11:06 UTC (permalink / raw) To: 69328 Cc: Timothy Sample, Ludovic Courtès, Christopher Baines, Josselin Poiret, Ludovic Courtès, Mathieu Othacehe, Ricardo Wurmus, Simon Tournier, Tobias Geerinckx-Rice 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(-) 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 ^ permalink raw reply related [flat|nested] 33+ messages in thread
* [bug#69328] [PATCH v2 08/12] svn-download: Use ‘swh-download-directory-by-nar-hash’. 2024-03-05 10:58 ` Ludovic Courtès ` (7 preceding siblings ...) 2024-03-05 11:06 ` [bug#69328] [PATCH v2 07/12] hg-download: Use ‘swh-download-directory-by-nar-hash’ Ludovic Courtès @ 2024-03-05 11:06 ` Ludovic Courtès 2024-03-05 11:06 ` [bug#69328] [PATCH v2 09/12] bzr-download: Implement nar fallback Ludovic Courtès ` (3 subsequent siblings) 12 siblings, 0 replies; 33+ messages in thread From: Ludovic Courtès @ 2024-03-05 11:06 UTC (permalink / raw) To: 69328 Cc: Timothy Sample, Ludovic Courtès, Christopher Baines, Josselin Poiret, Ludovic Courtès, Mathieu Othacehe, Ricardo Wurmus, Simon Tournier, Tobias Geerinckx-Rice Fixes <https://issues.guix.gnu.org/43442>. * 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(-) 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 ^ permalink raw reply related [flat|nested] 33+ messages in thread
* [bug#69328] [PATCH v2 09/12] bzr-download: Implement nar fallback. 2024-03-05 10:58 ` Ludovic Courtès ` (8 preceding siblings ...) 2024-03-05 11:06 ` [bug#69328] [PATCH v2 08/12] svn-download: " Ludovic Courtès @ 2024-03-05 11:06 ` Ludovic Courtès 2024-03-05 11:06 ` [bug#69328] [PATCH v2 10/12] download-nar: Distinguish ‘output’ and ‘item’ parameter Ludovic Courtès ` (2 subsequent siblings) 12 siblings, 0 replies; 33+ messages in thread From: Ludovic Courtès @ 2024-03-05 11:06 UTC (permalink / raw) To: 69328 Cc: Timothy Sample, Ludovic Courtès, Christopher Baines, Josselin Poiret, Ludovic Courtès, Mathieu Othacehe, Ricardo Wurmus, Simon Tournier, Tobias Geerinckx-Rice * 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(-) 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 ^ permalink raw reply related [flat|nested] 33+ messages in thread
* [bug#69328] [PATCH v2 10/12] download-nar: Distinguish ‘output’ and ‘item’ parameter. 2024-03-05 10:58 ` Ludovic Courtès ` (9 preceding siblings ...) 2024-03-05 11:06 ` [bug#69328] [PATCH v2 09/12] bzr-download: Implement nar fallback Ludovic Courtès @ 2024-03-05 11:06 ` Ludovic Courtès 2024-03-05 11:06 ` [bug#69328] [PATCH v2 11/12] perform-download: Allow use of ‘download-nar’ for ‘--check’ builds Ludovic Courtès 2024-03-05 11:07 ` [bug#69328] [PATCH v2 12/12] download: Honor ‘GUIX_DOWNLOAD_METHODS’ environment variable Ludovic Courtès 12 siblings, 0 replies; 33+ messages in thread From: Ludovic Courtès @ 2024-03-05 11:06 UTC (permalink / raw) To: 69328; +Cc: Timothy Sample, Ludovic Courtès 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(-) 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 ^ permalink raw reply related [flat|nested] 33+ messages in thread
* [bug#69328] [PATCH v2 11/12] perform-download: Allow use of ‘download-nar’ for ‘--check’ builds. 2024-03-05 10:58 ` Ludovic Courtès ` (10 preceding siblings ...) 2024-03-05 11:06 ` [bug#69328] [PATCH v2 10/12] download-nar: Distinguish ‘output’ and ‘item’ parameter Ludovic Courtès @ 2024-03-05 11:06 ` Ludovic Courtès 2024-03-05 11:07 ` [bug#69328] [PATCH v2 12/12] download: Honor ‘GUIX_DOWNLOAD_METHODS’ environment variable Ludovic Courtès 12 siblings, 0 replies; 33+ messages in thread From: Ludovic Courtès @ 2024-03-05 11:06 UTC (permalink / raw) To: 69328 Cc: Timothy Sample, Ludovic Courtès, Christopher Baines, Josselin Poiret, Ludovic Courtès, Mathieu Othacehe, Ricardo Wurmus, Simon Tournier, Tobias Geerinckx-Rice 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(-) 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 ^ permalink raw reply related [flat|nested] 33+ messages in thread
* [bug#69328] [PATCH v2 12/12] download: Honor ‘GUIX_DOWNLOAD_METHODS’ environment variable. 2024-03-05 10:58 ` Ludovic Courtès ` (11 preceding siblings ...) 2024-03-05 11:06 ` [bug#69328] [PATCH v2 11/12] perform-download: Allow use of ‘download-nar’ for ‘--check’ builds Ludovic Courtès @ 2024-03-05 11:07 ` Ludovic Courtès 12 siblings, 0 replies; 33+ messages in thread From: Ludovic Courtès @ 2024-03-05 11:07 UTC (permalink / raw) To: 69328 Cc: Timothy Sample, Ludovic Courtès, Christopher Baines, Josselin Poiret, Ludovic Courtès, Mathieu Othacehe, Ricardo Wurmus, Simon Tournier, Tobias Geerinckx-Rice 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(-) 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? #t #:env-vars `(("url" . ,(object->string - (match (%download-fallback-test) - ('content-addressed-mirrors - "https://example.org/does-not-exist") - (_ - (git-reference-url ref))))) + (git-reference-url ref))) ("commit" . ,(git-reference-commit ref)) ("recursive?" . ,(object->string - (git-reference-recursive? ref)))) + (git-reference-recursive? ref))) + ,@(if (%download-methods) + `(("download-methods" + . ,(object->string (%download-methods)))) + '())) #:leaked-env-vars '("http_proxy" "https_proxy" "LC_ALL" "LC_MESSAGES" "LANG" "COLUMNS") diff --git a/guix/hg-download.scm b/guix/hg-download.scm index dd28d9c244..55d908817f 100644 --- a/guix/hg-download.scm +++ b/guix/hg-download.scm @@ -84,6 +84,7 @@ (define* (hg-fetch ref hash-algo hash (define modules (delete '(guix config) (source-module-closure '((guix build hg) + (guix build download) (guix build download-nar) (guix swh))))) @@ -94,6 +95,8 @@ (define* (hg-fetch ref hash-algo hash #~(begin (use-modules (guix build hg) (guix build utils) ;for `set-path-environment-variable' + ((guix build download) + #:select (download-method-enabled?)) (guix build download-nar) (guix swh) (ice-9 match)) @@ -106,28 +109,35 @@ (define* (hg-fetch ref hash-algo hash (setvbuf (current-output-port) 'line) (setvbuf (current-error-port) 'line) - (or (hg-fetch '#$(hg-reference-url ref) - '#$(hg-reference-changeset ref) - #$output - #:hg-command (string-append #+hg "/bin/hg")) - (download-nar #$output) + (or (and (download-method-enabled? 'upstream) + (hg-fetch '#$(hg-reference-url ref) + '#$(hg-reference-changeset ref) + #$output + #:hg-command (string-append #+hg "/bin/hg"))) + (and (download-method-enabled? 'nar) + (download-nar #$output)) ;; 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. - (parameterize ((%verify-swh-certificate? #f)) - (format (current-error-port) - "Trying to download from Software Heritage...~%") - (or (swh-download-directory-by-nar-hash #$hash '#$hash-algo - #$output) - (swh-download #$(hg-reference-url ref) - #$(hg-reference-changeset ref) - #$output)))))))) + (and (download-method-enabled? 'swh) + (parameterize ((%verify-swh-certificate? #f)) + (format (current-error-port) + "Trying to download from Software Heritage...~%") + (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 #: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 #:local-build? #t ;don't offload repo cloning #:hash-algo hash-algo diff --git a/guix/scripts/perform-download.scm b/guix/scripts/perform-download.scm index b96959a09e..5079d0ea71 100644 --- a/guix/scripts/perform-download.scm +++ b/guix/scripts/perform-download.scm @@ -21,7 +21,7 @@ (define-module (guix scripts perform-download) #:use-module (guix scripts) #:use-module (guix derivations) #:use-module ((guix store) #:select (derivation-path? store-path?)) - #:autoload (guix build download) (url-fetch) + #:autoload (guix build download) (%download-methods url-fetch) #:autoload (guix build git) (git-fetch-with-fallback) #:autoload (guix config) (%git) #:use-module (ice-9 match) @@ -55,7 +55,8 @@ (define* (perform-download drv output (executable "executable") (mirrors "mirrors") (content-addressed-mirrors "content-addressed-mirrors") - (disarchive-mirrors "disarchive-mirrors")) + (disarchive-mirrors "disarchive-mirrors") + (download-methods "download-methods")) (unless url (leave (G_ "~a: missing URL~%") (derivation-file-name drv))) @@ -64,26 +65,30 @@ (define* (perform-download drv output (algo (derivation-output-hash-algo drv-output)) (hash (derivation-output-hash drv-output))) ;; We're invoked by the daemon, which gives us write access to OUTPUT. - (when (url-fetch url output - #:print-build-trace? print-build-trace? - #:mirrors (if mirrors - (call-with-input-file mirrors read) - '()) - #:content-addressed-mirrors - (if content-addressed-mirrors - (call-with-input-file content-addressed-mirrors - (lambda (port) - (eval (read port) %user-module))) - '()) - #:disarchive-mirrors - (if disarchive-mirrors - (call-with-input-file disarchive-mirrors read) - '()) - #:hashes `((,algo . ,hash)) + (when (parameterize ((%download-methods + (and download-methods + (call-with-input-string download-methods + read)))) + (url-fetch url output + #:print-build-trace? print-build-trace? + #:mirrors (if mirrors + (call-with-input-file mirrors read) + '()) + #:content-addressed-mirrors + (if content-addressed-mirrors + (call-with-input-file content-addressed-mirrors + (lambda (port) + (eval (read port) %user-module))) + '()) + #:disarchive-mirrors + (if disarchive-mirrors + (call-with-input-file disarchive-mirrors read) + '()) + #:hashes `((,algo . ,hash)) - ;; Since DRV's output hash is known, X.509 certificate - ;; validation is pointless. - #:verify-certificate? #f) + ;; Since DRV's output hash is known, X.509 certificate + ;; validation is pointless. + #:verify-certificate? #f)) (when (and executable (string=? executable "1")) (chmod output #o755)))))) @@ -96,7 +101,8 @@ (define* (perform-git-download drv output 'bmRepair' builds." (derivation-let drv ((url "url") (commit "commit") - (recursive? "recursive?")) + (recursive? "recursive?") + (download-methods "download-methods")) (unless url (leave (G_ "~a: missing Git URL~%") (derivation-file-name drv))) (unless commit @@ -114,14 +120,18 @@ (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-methods + (and download-methods + (call-with-input-string download-methods + read)))) + ;; 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) (when (zero? (getuid)) diff --git a/guix/svn-download.scm b/guix/svn-download.scm index 64af996a06..17a7f4f957 100644 --- a/guix/svn-download.scm +++ b/guix/svn-download.scm @@ -93,6 +93,7 @@ (define* (svn-fetch ref hash-algo hash (define build (with-imported-modules (source-module-closure '((guix build svn) + (guix build download) (guix build download-nar) (guix build utils) (guix swh))) @@ -100,23 +101,28 @@ (define* (svn-fetch ref hash-algo hash guile-lzlib) #~(begin (use-modules (guix build svn) + ((guix build download) + #:select (download-method-enabled?)) (guix build download-nar) (guix swh) (ice-9 match)) - (or (svn-fetch (getenv "svn url") - (string->number (getenv "svn revision")) - #$output - #:svn-command #+(file-append svn "/bin/svn") - #:recursive? (match (getenv "svn recursive?") - ("yes" #t) - (_ #f)) - #:user-name (getenv "svn user name") - #:password (getenv "svn password")) - (download-nar #$output) - (parameterize ((%verify-swh-certificate? #f)) - (swh-download-directory-by-nar-hash #$hash '#$hash-algo - #$output))))))) + (or (and (download-method-enabled? 'upstream) + (svn-fetch (getenv "svn url") + (string->number (getenv "svn revision")) + #$output + #:svn-command #+(file-append svn "/bin/svn") + #:recursive? (match (getenv "svn recursive?") + ("yes" #t) + (_ #f)) + #:user-name (getenv "svn user name") + #:password (getenv "svn password"))) + (and (download-method-enabled? 'nar) + (download-nar #$output)) + (and (download-method-enabled? 'swh) + (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 @@ -139,7 +145,11 @@ (define* (svn-fetch ref hash-algo hash ,@(if (svn-reference-password ref) `(("svn password" . ,(svn-reference-password ref))) - '())) + '()) + ,@(match (getenv "GUIX_DOWNLOAD_METHODS") + (#f '()) + (value + `(("GUIX_DOWNLOAD_METHODS" . ,value))))) #:system system #:hash-algo hash-algo @@ -178,6 +188,7 @@ (define* (svn-multi-fetch ref hash-algo hash (define build (with-imported-modules (source-module-closure '((guix build svn) + (guix build download) (guix build download-nar) (guix build utils) (guix swh))) @@ -186,6 +197,8 @@ (define* (svn-multi-fetch ref hash-algo hash #~(begin (use-modules (guix build svn) (guix build utils) + ((guix build download) + #:select (download-method-enabled?)) (guix build download-nar) (guix swh) (srfi srfi-1) @@ -197,30 +210,33 @@ (define* (svn-multi-fetch ref hash-algo hash ;; single file. (unless (string-suffix? "/" location) (mkdir-p (string-append #$output "/" (dirname location)))) - (svn-fetch (string-append (getenv "svn url") "/" location) - (string->number (getenv "svn revision")) - (if (string-suffix? "/" location) - (string-append #$output "/" location) - (string-append #$output "/" (dirname location))) - #:svn-command #+(file-append svn "/bin/svn") - #:recursive? (match (getenv "svn recursive?") - ("yes" #t) - (_ #f)) - #:user-name (getenv "svn user name") - #:password (getenv "svn password"))) + (and (download-method-enabled? 'upstream) + (svn-fetch (string-append (getenv "svn url") "/" location) + (string->number (getenv "svn revision")) + (if (string-suffix? "/" location) + (string-append #$output "/" location) + (string-append #$output "/" (dirname location))) + #:svn-command #+(file-append svn "/bin/svn") + #:recursive? (match (getenv "svn recursive?") + ("yes" #t) + (_ #f)) + #:user-name (getenv "svn user name") + #:password (getenv "svn password")))) (call-with-input-string (getenv "svn locations") read)) (begin (when (file-exists? #$output) (delete-file-recursively #$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))))))))) + (or (and (download-method-enabled? 'nar) + (download-nar #$output)) + (and (download-method-enabled? 'swh) + ;; 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>. + (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 @@ -245,7 +261,11 @@ (define* (svn-multi-fetch ref hash-algo hash ,@(if (svn-multi-reference-password ref) `(("svn password" . ,(svn-multi-reference-password ref))) - '())) + '()) + ,@(match (getenv "GUIX_DOWNLOAD_METHODS") + (#f '()) + (value + `(("GUIX_DOWNLOAD_METHODS" . ,value))))) #:leaked-env-vars '("http_proxy" "https_proxy" "LC_ALL" "LC_MESSAGES" "LANG" -- 2.41.0 ^ permalink raw reply related [flat|nested] 33+ messages in thread
end of thread, other threads:[~2024-03-09 18:52 UTC | newest] Thread overview: 33+ messages (download: mbox.gz follow: Atom feed -- links below jump to the message on this page -- 2024-02-23 14:22 [bug#69328] [PATCH 00/12] Better source code recovery from SWH Ludovic Courtès 2024-02-23 15:48 ` [bug#69328] [PATCH 01/12] lint: Switch to SRFI-71 Ludovic Courtès 2024-02-23 15:48 ` [bug#69328] [PATCH 02/12] lint: archival: Fix crash in non-Git case Ludovic Courtès 2024-02-23 15:48 ` [bug#69328] [PATCH 03/12] lint: archival: Trigger “Save Code Now” for VCSes other than Git Ludovic Courtès 2024-02-23 15:48 ` [bug#69328] [PATCH 04/12] swh: Add ‘type’ field to <visit> Ludovic Courtès 2024-02-23 15:48 ` [bug#69328] [PATCH 05/12] swh: ‘origin-visits’ takes an optional ‘max’ parameter Ludovic Courtès 2024-02-23 15:48 ` [bug#69328] [PATCH 06/12] swh: ‘lookup-origin-revision’ handles branches pointing to directories Ludovic Courtès 2024-02-23 15:48 ` [bug#69328] [PATCH 07/12] hg-download: Use ‘swh-download-directory-by-nar-hash’ Ludovic Courtès 2024-02-23 15:48 ` [bug#69328] [PATCH 08/12] svn-download: " Ludovic Courtès 2024-02-23 15:48 ` [bug#69328] [PATCH 09/12] bzr-download: Implement nar fallback Ludovic Courtès 2024-02-23 15:48 ` [bug#69328] [PATCH 10/12] download-nar: Distinguish ‘output’ and ‘item’ parameter Ludovic Courtès 2024-02-23 15:48 ` [bug#69328] [PATCH 11/12] perform-download: Allow use of ‘download-nar’ for ‘--check’ builds Ludovic Courtès 2024-02-23 15:48 ` [bug#69328] [PATCH 12/12] download: Honor ‘GUIX_DOWNLOAD_SEQUENCE’ environment variable Ludovic Courtès 2024-03-03 4:53 ` Timothy Sample 2024-03-05 10:26 ` Ludovic Courtès 2024-02-23 15:53 ` [bug#69328] [PATCH 00/12] Better source code recovery from SWH Ludovic Courtès 2024-03-03 4:54 ` Timothy Sample 2024-03-05 10:58 ` Ludovic Courtès 2024-03-05 11:06 ` [bug#69328] [PATCH v2 " Ludovic Courtès 2024-03-07 18:38 ` Simon Tournier 2024-03-09 18:51 ` bug#69328: " Ludovic Courtès 2024-03-05 11:06 ` [bug#69328] [PATCH v2 01/12] lint: Switch to SRFI-71 Ludovic Courtès 2024-03-05 11:06 ` [bug#69328] [PATCH v2 02/12] lint: archival: Fix crash in non-Git case Ludovic Courtès 2024-03-05 11:06 ` [bug#69328] [PATCH v2 03/12] lint: archival: Trigger “Save Code Now” for VCSes other than Git Ludovic Courtès 2024-03-05 11:06 ` [bug#69328] [PATCH v2 04/12] swh: Add ‘type’ field to <visit> Ludovic Courtès 2024-03-05 11:06 ` [bug#69328] [PATCH v2 05/12] swh: ‘origin-visits’ takes an optional ‘max’ parameter Ludovic Courtès 2024-03-05 11:06 ` [bug#69328] [PATCH v2 06/12] swh: ‘lookup-origin-revision’ handles branches pointing to directories Ludovic Courtès 2024-03-05 11:06 ` [bug#69328] [PATCH v2 07/12] hg-download: Use ‘swh-download-directory-by-nar-hash’ Ludovic Courtès 2024-03-05 11:06 ` [bug#69328] [PATCH v2 08/12] svn-download: " Ludovic Courtès 2024-03-05 11:06 ` [bug#69328] [PATCH v2 09/12] bzr-download: Implement nar fallback Ludovic Courtès 2024-03-05 11:06 ` [bug#69328] [PATCH v2 10/12] download-nar: Distinguish ‘output’ and ‘item’ parameter Ludovic Courtès 2024-03-05 11:06 ` [bug#69328] [PATCH v2 11/12] perform-download: Allow use of ‘download-nar’ for ‘--check’ builds Ludovic Courtès 2024-03-05 11:07 ` [bug#69328] [PATCH v2 12/12] download: Honor ‘GUIX_DOWNLOAD_METHODS’ environment variable Ludovic Courtès
Code repositories for project(s) associated with this public inbox https://git.savannah.gnu.org/cgit/guix.git This is a public inbox, see mirroring instructions for how to clone and mirror all data and code used for this inbox; as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).