From cfc63f673fb00dc30f6fd7916e78855721885d73 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Mon, 19 Feb 2024 15:39:19 +0100 Subject: lint: Switch to SRFI-71. * guix/lint.scm: Switch from SRFI-11 to SRFI-71. Change-Id: I62e6cd304ad73570bd12bd67f7051566205596bb --- guix/lint.scm | 9 ++++----- 1 file changed, 4 insertions(+), 5 deletions(-) (limited to 'guix') 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 @@ #: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 @@ for connections to complete; when TIMEOUT is #f, wait as long as needed." ;; 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 @@ display a message including MESSAGE and return ERROR-VALUE." (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)) -- cgit v1.2.3 From 3328dec08757a14ae47f4cbd7017b7518adc689e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Mon, 19 Feb 2024 17:51:34 +0100 Subject: lint: archival: Fix crash in non-Git case. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit 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(+) (limited to 'guix') 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 @@ Disarchive entry refers to non-existent SWH directory '~a'") (list id) #:field 'source))))))) ((? content?) + '()) + ((? string? swhid) '()))) '())) ((? local-file?) -- cgit v1.2.3 From 47a0e5d9fb2209a27c2bffa163becbcb3356bf00 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Mon, 19 Feb 2024 17:53:52 +0100 Subject: =?UTF-8?q?lint:=20archival:=20Trigger=20=E2=80=9CSave=20Code=20No?= =?UTF-8?q?w=E2=80=9D=20for=20VCSes=20other=20than=20Git.?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Until now, ‘save-origin’ would be called only when given a . 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 +++++++++++++++++++++++++++++++++++++--------------------- 1 file changed, 89 insertions(+), 51 deletions(-) (limited to 'guix') 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 @@ 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 @@ directory identifiers the spec refers to. Otherwise return #f." (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 + ;; . + (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 @@ request to Software Heritage. 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 @@ try again later") '()) (#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 - ;; . - (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 @@ try again later") (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 @@ source is not an origin, it cannot be archived") #: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) '() -- cgit v1.2.3 From a813d6890b9ba69f6a738b43919a6359478868cd Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Tue, 20 Feb 2024 14:30:41 +0100 Subject: =?UTF-8?q?swh:=20Add=20=E2=80=98type=E2=80=99=20field=20to=20.?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * guix/swh.scm ()[type]: New field. Change-Id: I7677984c7daef38d8f3c3bef19723fa0efb035ba --- guix/swh.scm | 2 ++ 1 file changed, 2 insertions(+) (limited to 'guix') 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 @@ visit-snapshot-url visit-status visit-number + visit-type visit-snapshot snapshot? @@ -312,6 +313,7 @@ FALSE-IF-404? is true, return #f upon 404 responses." (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")) ;; -- cgit v1.2.3 From ed9d7d84314d4bea1ff610420cf09f79d9d82719 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Tue, 20 Feb 2024 14:38:23 +0100 Subject: =?UTF-8?q?swh:=20=E2=80=98origin-visits=E2=80=99=20takes=20an=20o?= =?UTF-8?q?ptional=20=E2=80=98max=E2=80=99=20parameter.?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * 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(-) (limited to 'guix') 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 @@ and use of ALGORITHM." 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)))))) -- cgit v1.2.3 From ddd455c0dd5a527f3c7e94b8b9056155facb37e6 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Tue, 20 Feb 2024 16:52:34 +0100 Subject: =?UTF-8?q?swh:=20=E2=80=98lookup-origin-revision=E2=80=99=20handl?= =?UTF-8?q?es=20branches=20pointing=20to=20directories.?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Fixes . * 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 +++++++++++++++++++++++++++++++++--------------------------- 1 file changed, 33 insertions(+), 27 deletions(-) (limited to 'guix') 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 @@ could not be found." (_ #f))))) (define (branch-target branch) - "Return the target of BRANCH, either a or a ." + "Return the target of BRANCH: a , a , 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 corresponding to the given TAG for the repository @@ -537,31 +543,31 @@ URL could not be found." (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." -- cgit v1.2.3 From 2a9f817ffdf66cc4b20538eec6232bfa504dba9d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Tue, 20 Feb 2024 17:29:02 +0100 Subject: =?UTF-8?q?hg-download:=20Use=20=E2=80=98swh-download-directory-by?= =?UTF-8?q?-nar-hash=E2=80=99.?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit 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(-) (limited to 'guix') 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 +;;; Copyright © 2014-2017, 2019, 2024 Ludovic Courtès ;;; Copyright © 2016 Ricardo Wurmus ;;; Copyright © 2021 Xinglu Chen ;;; @@ -117,9 +117,11 @@ HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #f." (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 -- cgit v1.2.3 From 0e73f933b291c7e154c7e019b6de1e2f3a97e4c1 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Tue, 20 Feb 2024 18:01:10 +0100 Subject: =?UTF-8?q?svn-download:=20Use=20=E2=80=98swh-download-directory-b?= =?UTF-8?q?y-nar-hash=E2=80=99.?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Fixes . * 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(-) (limited to 'guix') 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 +;;; Copyright © 2014-2016, 2019, 2021-2024 Ludovic Courtès ;;; Copyright © 2014 Sree Harsha Totakura ;;; Copyright © 2017, 2019, 2021 Ricardo Wurmus ;;; @@ -94,12 +94,14 @@ HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #f." (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 @@ HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #f." (_ #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 @@ HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #f." (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 @@ HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #f." (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: + ;; . + (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 -- cgit v1.2.3 From 8a42fc71401fce2086111f5d319aeeddf202513a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Fri, 23 Feb 2024 14:17:07 +0100 Subject: bzr-download: Implement nar fallback. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * 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(-) (limited to 'guix') 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 @@ revision identifier. Return #t on success, else throw an exception." (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 +;;; Copyright © 2024 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -51,20 +52,40 @@ (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 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 @@ HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #f." "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 -- cgit v1.2.3 From 3e9bea7ee30a3425011afb8e2f70b7a8fe6a404b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Fri, 23 Feb 2024 14:20:41 +0100 Subject: =?UTF-8?q?download-nar:=20Distinguish=20=E2=80=98output=E2=80=99?= =?UTF-8?q?=20and=20=E2=80=98item=E2=80=99=20parameter.?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit 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(-) (limited to 'guix') 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 +;;; Copyright © 2017, 2019, 2020, 2024 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -57,9 +57,9 @@ ITEM." (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 @@ success, #f otherwise." #: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)))) (() -- cgit v1.2.3 From abd0cca2a9ccba4e57fd2cc318139658559979cf Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Fri, 23 Feb 2024 14:34:13 +0100 Subject: =?UTF-8?q?perform-download:=20Allow=20use=20of=20=E2=80=98downloa?= =?UTF-8?q?d-nar=E2=80=99=20for=20=E2=80=98--check=E2=80=99=20builds.?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit 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(-) (limited to 'guix') 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 @@ fetched, recursively. Return #t on success, #f otherwise." (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 @@ Note: OUTPUT may differ from the 'out' value of DRV, notably for 'bmCheck' or ;; 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) -- cgit v1.2.3 From 2f441fc738976175d438f7942211b1894e2eb416 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Fri, 23 Feb 2024 14:42:43 +0100 Subject: =?UTF-8?q?download:=20Honor=20=E2=80=98GUIX=5FDOWNLOAD=5FMETHODS?= =?UTF-8?q?=E2=80=99=20environment=20variable.?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit 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 | 72 ++++++++++++++++++-------------- guix/svn-download.scm | 88 ++++++++++++++++++++++++--------------- 9 files changed, 231 insertions(+), 155 deletions(-) (limited to 'guix') 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 +;;; 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 @@ #: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 @@ true, verify HTTPS certificates; otherwise simply ignore them." (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 @@ otherwise simply ignore them." 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 @@ otherwise simply ignore them." (() ;; 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 @@ 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 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 @@ #: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 @@ HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #f." (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 @@ HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #f." #: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 +;;; Copyright © 2014-2017, 2019, 2024 Ludovic Courtès ;;; Copyright © 2014 Sree Harsha Totakura ;;; Copyright © 2015 Mark H Weaver ;;; @@ -73,6 +73,7 @@ HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #f." (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 @@ HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #f." 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 +;;; 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 @@ #: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 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 @@ download by itself using its own dependencies." ("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 @@ download by itself using its own dependencies." ;; 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 @@ name in the store." (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 @@ name in the store." #: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 @@ #: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 @@ respective documentation." ;; 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 @@ download by itself using its own dependencies." #: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 @@ HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #f." (define modules (delete '(guix config) (source-module-closure '((guix build hg) + (guix build download) (guix build download-nar) (guix swh))))) @@ -94,6 +95,8 @@ HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #f." #~(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 @@ HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #f." (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 @@ #: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 @@ Note: OUTPUT may differ from the 'out' value of DRV, notably for 'bmCheck' or (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 @@ Note: OUTPUT may differ from the 'out' value of DRV, notably for 'bmCheck' or (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)) - - ;; Since DRV's output hash is known, X.509 certificate - ;; validation is pointless. - #:verify-certificate? #f) + (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)) (when (and executable (string=? executable "1")) (chmod output #o755)))))) @@ -96,7 +101,8 @@ Note: OUTPUT may differ from the 'out' value of DRV, notably for 'bmCheck' or '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 @@ Note: OUTPUT may differ from the 'out' value of DRV, notably for 'bmCheck' or ;; 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 @@ HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #f." (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 @@ HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #f." 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 @@ HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #f." ,@(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 @@ HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #f." (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 @@ HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #f." #~(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 @@ HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #f." ;; 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: - ;; . - (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: + ;; . + (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 @@ HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #f." ,@(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" -- cgit v1.2.3 From 92bd81a96f4cac9d0fe628b82ffb1d127ad3e42f Mon Sep 17 00:00:00 2001 From: Efraim Flashner Date: Wed, 6 Mar 2024 13:06:09 +0200 Subject: transformations: Add support for rust. * guix/transformations.scm (tuning-compiler): Add support for rustc. Change-Id: I6db596a586eda648666550cdcadaa5e1704cb79c --- guix/transformations.scm | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/transformations.scm b/guix/transformations.scm index 132ccd957a..f02b9f94d6 100644 --- a/guix/transformations.scm +++ b/guix/transformations.scm @@ -2,7 +2,7 @@ ;;; Copyright © 2016-2023 Ludovic Courtès ;;; Copyright © 2021 Marius Bakke ;;; Copyright © 2023 Sarthak Shah -;;; Copyright © 2023 Efraim Flashner +;;; Copyright © 2023, 2024 Efraim Flashner ;;; Copyright © 2023 Ekaitz Zarraga ;;; ;;; This file is part of GNU Guix. @@ -499,6 +499,10 @@ actual compiler." "-Dcpu=" (string-replace-substring #$micro-architecture "-" "_")))) + ((and (search-next "rustc") + (string=? next (search-next "rustc"))) + (list "-C" (string-append "target_cpu=" + #$micro-architecture))) (else (list (string-append "-march=" #$micro-architecture)))))))))))) @@ -519,7 +523,7 @@ actual compiler." (symlink #$program (string-append bin "/" program))) '("cc" "gcc" "clang" "g++" "c++" "clang++" - "go" "zig"))))))) + "go" "rustc" "zig"))))))) (define (build-system-with-tuning-compiler bs micro-architecture) "Return a variant of BS, a build system, that ensures that the compiler that -- cgit v1.2.3 From a26bce55e60aa3444c4378d3996f3aa41b9661e9 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Mon, 11 Mar 2024 22:07:43 +0100 Subject: time-machine: Allow time travels to v0.16.0. * guix/scripts/time-machine.scm (%oldest-possible-commit): Change to v0.16.0. * tests/guix-time-machine.sh: Adjust comment. Change-Id: I9ad82bd45fee0d172b5348a8ae16e990338a3a97 --- guix/scripts/time-machine.scm | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/scripts/time-machine.scm b/guix/scripts/time-machine.scm index 2c30fe7cfd..d9ce85df84 100644 --- a/guix/scripts/time-machine.scm +++ b/guix/scripts/time-machine.scm @@ -1,6 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2019 Konrad Hinsen -;;; Copyright © 2019, 2020, 2021, 2023 Ludovic Courtès +;;; Copyright © 2019-2021, 2023-2024 Ludovic Courtès ;;; Copyright © 2021 Simon Tournier ;;; Copyright © 2023 Maxim Cournoyer ;;; @@ -147,7 +147,7 @@ Execute COMMAND ARGS... in an older version of Guix.\n")) ;;; firmed up in v1.0.0; it is the oldest, safest commit that can be travelled ;;; to. (define %oldest-possible-commit - "6298c3ffd9654d3231a6f25390b056483e8f407c") ;v1.0.0 + "4a0b87f0ec5b6c2dcf82b372dd20ca7ea6acdd9c") ;v0.16.0 (define %reference-channels (list (channel (inherit %default-guix-channel) -- cgit v1.2.3 From 06baf4d6ba187e4f56f15692b6013cf1c89df7f1 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Tue, 19 Mar 2024 15:53:02 +0100 Subject: =?UTF-8?q?profiles:=20=E2=80=98read-manifest=E2=80=99=20raises=20?= =?UTF-8?q?to=20=E2=80=98&profile-error=E2=80=99=20upon=20version=20mismat?= =?UTF-8?q?ch.?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * guix/profiles.scm (sexp->manifest): In the catch-all clause, raise to ‘&profile-error’ in addition to ‘&message’. Change-Id: Ieb08187b388531c2157bfe67fb1b7319dbbb4ff3 --- guix/profiles.scm | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/profiles.scm b/guix/profiles.scm index ce2f8337bf..2d695a52f8 100644 --- a/guix/profiles.scm +++ b/guix/profiles.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013-2023 Ludovic Courtès +;;; Copyright © 2013-2024 Ludovic Courtès ;;; Copyright © 2013 Nikita Karetnikov ;;; Copyright © 2014, 2016 Alex Kost ;;; Copyright © 2015 Mark H Weaver @@ -652,6 +652,8 @@ denoting a specific output of a package." vlist-null))) (_ (raise (condition + (&profile-error + (profile (and=> (source-property sexp 'filename) dirname))) (&message (message "unsupported manifest format"))))))) (define (read-manifest port) -- cgit v1.2.3 From c90a4e8dcd6ac650392ffcc039273baf145aa3cc Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Tue, 19 Mar 2024 12:56:49 +0100 Subject: =?UTF-8?q?describe:=20Try=20harder=20to=20find=20the=20=E2=80=98g?= =?UTF-8?q?uix=20pull=E2=80=99=20profile.?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Fixes . The strategy used by ‘current-profile’ so far would fail to find the right profile (the one created by ‘guix pull’ or ‘guix time-machine’) in cases where said profile is itself included in another profile. This happens, for instance, when running ‘guix shell -CW -- guix describe’, which, as a result, would display nothing but the ‘guix’ channel. This patch fixes that by having ‘current-profile’ not just check for the presence of a ‘manifest’ file but also parse it to determine whether it’s a ‘guix pull’ kind of manifest. * guix/describe.scm (find-profile): New procedure. (current-profile): Adjust to use it. Change-Id: I9194f54ce1496a6591e247c76203f497f28c330b --- guix/describe.scm | 48 +++++++++++++++++++++++++++++++++++++++--------- 1 file changed, 39 insertions(+), 9 deletions(-) (limited to 'guix') diff --git a/guix/describe.scm b/guix/describe.scm index 65cd79094b..a4ca2462f4 100644 --- a/guix/describe.scm +++ b/guix/describe.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2018, 2019, 2020, 2021 Ludovic Courtès +;;; Copyright © 2018-2021, 2024 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -27,6 +27,7 @@ sexp->channel manifest-entry-channel) #:use-module (srfi srfi-1) + #:use-module (srfi srfi-34) #:use-module (ice-9 match) #:export (current-profile current-profile-date @@ -55,20 +56,49 @@ ;; later on. (program-arguments)) +(define (find-profile program) + "Return the profile created by 'guix pull' or 'guix time-machine' that +PROGRAM lives in; PROGRAM is expected to end in \"/bin/guix\". Return #f if +such a profile could not be found." + (and (string-suffix? "/bin/guix" program) + ;; Note: We want to do _lexical dot-dot resolution_. Using ".." for + ;; real would instead take us into the /gnu/store directory that + ;; ~/.config/guix/current/bin points to, whereas we want to obtain + ;; ~/.config/guix/current. + (let ((candidate (dirname (dirname program)))) + (and (file-exists? (string-append candidate "/manifest")) + (let ((manifest (guard (c ((profile-error? c) #f)) + (profile-manifest candidate)))) + (define (fallback) + (or (and=> (false-if-exception (readlink program)) + find-profile) + (and=> (false-if-exception (readlink (dirname program))) + (lambda (target) + (find-profile (in-vicinity target "guix")))))) + + ;; Is CANDIDATE the "right" profile--the one created by 'guix + ;; pull'? It might be that CANDIDATE itself contains a + ;; symlink to the "right" profile; this happens for instance + ;; when using 'guix shell -CW'. Thus, if CANDIDATE doesn't + ;; fit the bill, dereference PROGRAM or its parent directory + ;; and try again. + (match (and manifest + (manifest-lookup manifest + (manifest-pattern (name "guix")))) + (#f + (fallback)) + (entry + (if (assq 'source (manifest-entry-properties entry)) + candidate + (fallback))))))))) + (define current-profile (mlambda () "Return the profile (created by 'guix pull') the calling process lives in, or #f if this is not applicable." (match initial-program-arguments ((program . _) - (and (string-suffix? "/bin/guix" program) - ;; Note: We want to do _lexical dot-dot resolution_. Using ".." - ;; for real would instead take us into the /gnu/store directory - ;; that ~/.config/guix/current/bin points to, whereas we want to - ;; obtain ~/.config/guix/current. - (let ((candidate (dirname (dirname program)))) - (and (file-exists? (string-append candidate "/manifest")) - candidate))))))) + (find-profile program))))) (define (current-profile-date) "Return the creation date of the current profile (produced by 'guix pull'), -- cgit v1.2.3 From b7931e6f5d606a7032d5408885ee43fa9e88454b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Tue, 19 Mar 2024 16:49:02 +0100 Subject: =?UTF-8?q?git=20authenticate:=20Document=20=E2=80=98--end?= =?UTF-8?q?=E2=80=99.?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * guix/scripts/git/authenticate.scm (show-help): Document ‘--end’. * doc/guix.texi (Invoking guix git authenticate): Likewise. Reported-by: Tomas Volf <~@wolfsden.cz> Change-Id: Ia646203ce2f721487de547c76b9488754c70db66 --- guix/scripts/git/authenticate.scm | 2 ++ 1 file changed, 2 insertions(+) (limited to 'guix') diff --git a/guix/scripts/git/authenticate.scm b/guix/scripts/git/authenticate.scm index 6ff5cee682..def4879e96 100644 --- a/guix/scripts/git/authenticate.scm +++ b/guix/scripts/git/authenticate.scm @@ -100,6 +100,8 @@ Authenticate the given Git checkout using COMMIT/SIGNER as its introduction.\n") (display (G_ " -k, --keyring=REFERENCE load keyring from REFERENCE, a Git branch")) + (display (G_ " + --end=COMMIT authenticate revisions up to COMMIT")) (display (G_ " --stats display commit signing statistics upon completion")) (display (G_ " -- cgit v1.2.3 From d282a31f52362b760b6f5021660494e8554bfbde Mon Sep 17 00:00:00 2001 From: Richard Sent Date: Thu, 14 Mar 2024 15:40:11 -0400 Subject: reconfigure: Skip starting new shepherd services with auto-start? #f MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Fixes . * guix/scripts/system/reconfigure.scm (upgrade-shepherd-services): Only add new shepherd services with auto-start? #t to to-start list. Change-Id: I268b921336fb1195ed76746eb6178889dbc258b4 Signed-off-by: Ludovic Courtès --- guix/scripts/system/reconfigure.scm | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/scripts/system/reconfigure.scm b/guix/scripts/system/reconfigure.scm index ff6242ffb4..9418060158 100644 --- a/guix/scripts/system/reconfigure.scm +++ b/guix/scripts/system/reconfigure.scm @@ -194,7 +194,8 @@ services as defined by OS." (filter live-service-running live-services))) (to-start (lset-difference eqv? (map shepherd-service-canonical-name - target-services) + (filter shepherd-service-auto-start? + target-services)) running)) (service-files (map shepherd-service-file target-services))) (eval #~(parameterize ((current-warning-port (%make-void-port "w"))) -- cgit v1.2.3