diff options
Diffstat (limited to 'guix/build')
| -rw-r--r-- | guix/build/bzr.scm | 3 | ||||
| -rw-r--r-- | guix/build/download-nar.scm | 12 | ||||
| -rw-r--r-- | guix/build/download.scm | 50 | ||||
| -rw-r--r-- | guix/build/git.scm | 27 | ||||
| -rw-r--r-- | guix/build/guile-build-system.scm | 43 | ||||
| -rw-r--r-- | guix/build/rakudo-build-system.scm | 8 |
6 files changed, 91 insertions, 52 deletions
diff --git a/guix/build/bzr.scm b/guix/build/bzr.scm index a0f5e15880..dede5e031a 100644 --- a/guix/build/bzr.scm +++ b/guix/build/bzr.scm @@ -37,6 +37,7 @@ 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/build/download-nar.scm b/guix/build/download-nar.scm index 3ba121b7fb..f26ad28cd0 100644 --- a/guix/build/download-nar.scm +++ b/guix/build/download-nar.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2017, 2019, 2020 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2017, 2019, 2020, 2024 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -57,9 +57,9 @@ 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)))) (() diff --git a/guix/build/download.scm b/guix/build/download.scm index db0a39084b..74b7486b7b 100644 --- a/guix/build/download.scm +++ b/guix/build/download.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012-2022 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2012-2022, 2024 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2015 Mark H Weaver <mhw@netris.org> ;;; Copyright © 2017 Tobias Geerinckx-Rice <me@tobias.gr> ;;; Copyright © 2021 Timothy Sample <samplet@ngyro.com> @@ -40,7 +40,10 @@ #: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 4c69365a7b..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 @@ -92,25 +94,30 @@ 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." - (or (git-fetch url commit directory - #:lfs? lfs? - #:recursive? recursive? - #:git-command git-command) - (download-nar directory) +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 (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/build/guile-build-system.scm b/guix/build/guile-build-system.scm index e7e7f2d0be..8927da224a 100644 --- a/guix/build/guile-build-system.scm +++ b/guix/build/guile-build-system.scm @@ -184,39 +184,38 @@ installed; this is useful for files that are meant to be included." (#f "") (path (string-append ":" path))))) - (let ((source-files + (let ((source-files (with-directory-excursion source-directory (find-files "." scheme-file-regexp)))) - (invoke-each - (filter-map (lambda (file) - (and (or (not not-compiled-file-regexp) - (not (string-match not-compiled-file-regexp - file))) - (cons* guild - "guild" "compile" - "-L" source-directory - "-o" (string-append go-dir - (file-sans-extension file) - ".go") - (string-append source-directory "/" file) - flags))) - source-files) - #:max-processes (parallel-job-count) - #:report-progress report-build-progress) - - (for-each - (lambda (file) + (for-each + (lambda (file) (install-file (string-append source-directory "/" file) (string-append module-dir "/" (dirname file)))) - source-files)) + source-files) + (invoke-each + (filter-map (lambda (file) + (and (or (not not-compiled-file-regexp) + (not (string-match not-compiled-file-regexp + file))) + (cons* guild + "guild" "compile" + "-L" source-directory + "-o" (string-append go-dir + (file-sans-extension file) + ".go") + (string-append source-directory "/" file) + flags))) + source-files) + #:max-processes (parallel-job-count) + #:report-progress report-build-progress)) #t)) (define* (install-documentation #:key outputs (documentation-file-regexp %documentation-file-regexp) #:allow-other-keys) - "Install files that mactch DOCUMENTATION-FILE-REGEXP." + "Install files that match DOCUMENTATION-FILE-REGEXP." (let* ((out (assoc-ref outputs "out")) (doc (string-append out "/share/doc/" (strip-store-file-name out)))) diff --git a/guix/build/rakudo-build-system.scm b/guix/build/rakudo-build-system.scm index 5cf1cc55bc..8f9a3b11d8 100644 --- a/guix/build/rakudo-build-system.scm +++ b/guix/build/rakudo-build-system.scm @@ -36,7 +36,11 @@ (define* (check #:key tests? inputs with-prove6? #:allow-other-keys) (if (and tests? (assoc-ref inputs "perl6-tap-harness")) ;(if (and tests? with-prove6?) - (invoke "prove6" "-I=lib" "t/") + (let ((test-files (find-files "t/" "\\.(rakutest|t|t6)$"))) + (invoke "raku" "-MTAP" "-e" + (string-append + "my @tests = <" (string-join test-files " ") ">; " + "TAP::Harness.new().run(@tests);"))) (format #t "test suite not run~%")) #t) @@ -59,7 +63,7 @@ #t) (begin (let ((inst (string-append (assoc-ref inputs "rakudo") - "/share/perl6/tools/install-dist.p6"))) + "/share/perl6/tools/install-dist.raku"))) (setenv "RAKUDO_RERESOLVE_DEPENDENCIES" "0") (setenv "RAKUDO_MODULE_DEBUG" "1") ; be verbose while building (invoke inst (string-append "--to=" perl6) "--for=site")))))) |