From patchwork Fri Feb 23 15:48:16 2024 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 8bit X-Patchwork-Submitter: =?utf-8?q?Ludovic_Court=C3=A8s?= X-Patchwork-Id: 60926 Return-Path: X-Original-To: patchwork@mira.cbaines.net Delivered-To: patchwork@mira.cbaines.net Received: by mira.cbaines.net (Postfix, from userid 113) id 1B6FF27BBEA; Fri, 23 Feb 2024 16:06:42 +0000 (GMT) X-Spam-Checker-Version: SpamAssassin 3.4.6 (2021-04-09) on mira.cbaines.net X-Spam-Level: X-Spam-Status: No, score=-2.7 required=5.0 tests=BAYES_00,DKIM_INVALID, DKIM_SIGNED,MAILING_LIST_MULTI,SPF_HELO_PASS,URIBL_BLOCKED autolearn=unavailable autolearn_force=no version=3.4.6 Received: from lists.gnu.org (lists.gnu.org [209.51.188.17]) by mira.cbaines.net (Postfix) with ESMTPS id 1792927BBE2 for ; Fri, 23 Feb 2024 16:06:39 +0000 (GMT) Received: from localhost ([::1] helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1rdY2K-00010T-Ov; Fri, 23 Feb 2024 11:04:33 -0500 Received: from eggs.gnu.org ([2001:470:142:3::10]) by lists.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1rdXo3-00048Y-9t for guix-patches@gnu.org; Fri, 23 Feb 2024 10:49:48 -0500 Received: from debbugs.gnu.org ([2001:470:142:5::43]) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_128_GCM_SHA256:128) (Exim 4.90_1) (envelope-from ) id 1rdXo3-0007GD-0M; Fri, 23 Feb 2024 10:49:47 -0500 Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1rdXoM-0002Au-4X; Fri, 23 Feb 2024 10:50:06 -0500 X-Loop: help-debbugs@gnu.org Subject: [bug#69328] [PATCH 12/12] download: Honor =?utf-8?b?4oCYR1VJWF9E?= =?utf-8?b?T1dOTE9BRF9TRVFVRU5DReKAmQ==?= environment variable. Resent-From: Ludovic =?utf-8?q?Court=C3=A8s?= Original-Sender: "Debbugs-submit" Resent-CC: guix@cbaines.net, dev@jpoiret.xyz, ludo@gnu.org, othacehe@gnu.org, rekado@elephly.net, zimon.toutoune@gmail.com, me@tobias.gr, guix-patches@gnu.org Resent-Date: Fri, 23 Feb 2024 15:50:06 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: followup 69328 X-GNU-PR-Package: guix-patches X-GNU-PR-Keywords: patch To: 69328@debbugs.gnu.org Cc: Ludovic =?utf-8?q?Court=C3=A8s?= , Christopher Baines , Josselin Poiret , Ludovic =?utf-8?q?Court=C3=A8s?= , Mathieu Othacehe , Ricardo Wurmus , Simon Tournier , Tobias Geerinckx-Rice X-Debbugs-Original-Xcc: Christopher Baines , Josselin Poiret , Ludovic =?utf-8?q?Court=C3=A8s?= , Mathieu Othacehe , Ricardo Wurmus , Simon Tournier , Tobias Geerinckx-Rice Received: via spool by 69328-submit@debbugs.gnu.org id=B69328.17087033698097 (code B ref 69328); Fri, 23 Feb 2024 15:50:06 +0000 Received: (at 69328) by debbugs.gnu.org; 23 Feb 2024 15:49:29 +0000 Received: from localhost ([127.0.0.1]:49235 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1rdXni-00026I-P7 for submit@debbugs.gnu.org; Fri, 23 Feb 2024 10:49:29 -0500 Received: from eggs.gnu.org ([209.51.188.92]:52700) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1rdXnT-00022c-Dd for 69328@debbugs.gnu.org; Fri, 23 Feb 2024 10:49:16 -0500 Received: from fencepost.gnu.org ([2001:470:142:3::e]) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1rdXn3-00079Q-OE; Fri, 23 Feb 2024 10:48:45 -0500 DKIM-Signature: v=1; a=rsa-sha256; q=dns/txt; c=relaxed/relaxed; d=gnu.org; s=fencepost-gnu-org; h=MIME-Version:References:In-Reply-To:Date:Subject:To: From; bh=7dHj5UY6RilYr0GvtapnfIYz21sM8sdq4MjGZ2AXJ9k=; b=Aphfp3JtVa9BE+FaxwpZ O8BfXvvoyRiDCY/VhNdHy4gLWK1E8uB6g9t7sobqFx2pEtePXPD+HV7rTmE3cxQSRzCO0RSfcGjCY yrM2qHVmo3DMx6LMP+ij/fpYO1L4ohUTp6uJ+vmxvNih83kAEaq2aYBeRPl0sYYWTpNJJNVSvsSK1 M4dtHMGVNq9S75mXi+Tj6csjgzKJOf6g7m4gy1oufDXhqhIyU6GoJMhkMEwKeCMgcxHtFCpFG9vSH ZaH5KNLyoSfCYbzIWapP4sbb/SyQwbXB+YSl6KQk8XqFZw4bVhV0j4xKHn6uWqyJkl8d22ZabA4Sp sUORwgpEGk99Ow==; From: Ludovic =?utf-8?q?Court=C3=A8s?= Date: Fri, 23 Feb 2024 16:48:16 +0100 Message-ID: <0eafb9b6a14808552c10a4d9d44eef1ec69897f9.1708697539.git.ludo@gnu.org> X-Mailer: git-send-email 2.41.0 In-Reply-To: References: MIME-Version: 1.0 X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list X-BeenThere: guix-patches@gnu.org List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: guix-patches-bounces+patchwork=mira.cbaines.net@gnu.org Sender: guix-patches-bounces+patchwork=mira.cbaines.net@gnu.org X-getmail-retrieved-from-mailbox: Patches 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 +;;; Copyright © 2012-2022, 2024 Ludovic Courtès ;;; Copyright © 2015 Mark H Weaver ;;; Copyright © 2017 Tobias Geerinckx-Rice ;;; Copyright © 2021 Timothy Sample @@ -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 +;;; Copyright © 2014-2017, 2019, 2024 Ludovic Courtès ;;; Copyright © 2014 Sree Harsha Totakura ;;; Copyright © 2015 Mark H Weaver ;;; @@ -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 +;;; Copyright © 2012-2021, 2024 Ludovic Courtès ;;; Copyright © 2013, 2014, 2015 Andreas Enge ;;; Copyright © 2015 Federico Beffa ;;; Copyright © 2016 Alex Griffin @@ -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"