From 2d83a25450d4b820c13d52152e5e9f1bbfb5d985 Mon Sep 17 00:00:00 2001 From: Ricardo Wurmus Date: Sun, 21 Jan 2024 11:05:46 +0100 Subject: import/cran: Generate rudimentary ARGUMENTS field. * guix/import/cran.scm (phases-for-inputs, maybe-arguments): New procedures. (description->package): Splice in result of MAYBE-ARGUMENTS. Change-Id: I578e1903f37c91bf865f0be49b04187ec372ed05 --- guix/import/cran.scm | 48 +++++++++++++++++++++++++++++++++++++++++++++++- 1 file changed, 47 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/import/cran.scm b/guix/import/cran.scm index d7497e6fb9..57a8e86fcb 100644 --- a/guix/import/cran.scm +++ b/guix/import/cran.scm @@ -672,6 +672,52 @@ of META, a package in REPOSITORY." (stringpackage repository meta #:key (license-prefix identity) (download-source download)) "Return the `package' s-expression for an R package published on REPOSITORY @@ -751,7 +797,7 @@ from the alist META, which was derived from the R package's DESCRIPTION file." `((properties ,`(,'quasiquote ((,'upstream-name . ,name))))) '()) (build-system r-build-system) - + ,@(maybe-arguments inputs) ,@(maybe-inputs (filter (upstream-input-type-predicate 'regular) inputs) 'inputs) -- cgit v1.2.3 From 2a43692aa74a4428b908fd4e11b239c9eb2f6542 Mon Sep 17 00:00:00 2001 From: Jean-Pierre De Jesus DIAZ Date: Fri, 19 Jan 2024 14:54:40 +0100 Subject: guix: Add ork1-elf platform. * doc/guix.texi: Document or1k-elf platform. * guix/platforms/or1k.scm (or1k-elf): New variable. * Makefile.am (MODULES): Add guix/platforms/or1k.scm. Change-Id: I3f71a0fa97f1ebd2bbdbf6cd00a93b477a123648 --- guix/platforms/or1k.scm | 28 ++++++++++++++++++++++++++++ 1 file changed, 28 insertions(+) create mode 100644 guix/platforms/or1k.scm (limited to 'guix') diff --git a/guix/platforms/or1k.scm b/guix/platforms/or1k.scm new file mode 100644 index 0000000000..bf983085c5 --- /dev/null +++ b/guix/platforms/or1k.scm @@ -0,0 +1,28 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2024 Foundation Devices, Inc. +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see . + +(define-module (guix platforms or1k) + #:use-module (guix platform) + #:use-module (guix records) + #:export (or1k-elf)) + +(define or1k-elf + (platform + (target "or1k-elf") + (system #f) + (glibc-dynamic-linker #f))) -- cgit v1.2.3 From 29353820f2df8e4434bbdae2d36b36d0151cc027 Mon Sep 17 00:00:00 2001 From: Ricardo Wurmus Date: Mon, 22 Jan 2024 12:38:27 +0100 Subject: import/cran: Also update annotation and experiment packages. * guix/import/cran.scm (latest-bioconductor-release): Determine package type and pass it to LATEST-BIOCONDUCTOR-PACKAGE-VERSION and BIOCONDUCTOR-URI. (%bioconductor-updater): Compose all bioconductor predicates. Change-Id: Icef3ae05e28ed0f2796d9abf90e51821d2dfcc4c --- guix/import/cran.scm | 19 ++++++++++++++++--- 1 file changed, 16 insertions(+), 3 deletions(-) (limited to 'guix') diff --git a/guix/import/cran.scm b/guix/import/cran.scm index 57a8e86fcb..d49bd96c9a 100644 --- a/guix/import/cran.scm +++ b/guix/import/cran.scm @@ -928,15 +928,25 @@ s-expression corresponding to that package, or #f on failure." (define upstream-name (package->upstream-name pkg)) + (define type + (cond + ((bioconductor-data-package? pkg) + 'annotation) + ((bioconductor-experiment-package? pkg) + 'experiment) + ((bioconductor-package? pkg) + #true) + (else #false))) + (define latest-version - (latest-bioconductor-package-version upstream-name)) + (latest-bioconductor-package-version upstream-name type)) (and latest-version ;; Bioconductor does not provide signatures. (upstream-source (package (package-name pkg)) (version latest-version) - (urls (bioconductor-uri upstream-name latest-version)) + (urls (bioconductor-uri upstream-name latest-version type)) (inputs (let ((meta (fetch-description 'bioconductor upstream-name))) (cran-package-inputs meta 'bioconductor)))))) @@ -990,7 +1000,10 @@ s-expression corresponding to that package, or #f on failure." (upstream-updater (name 'bioconductor) (description "Updater for Bioconductor packages") - (pred bioconductor-package?) + (pred (lambda (pkg) + (or (bioconductor-package? pkg) + (bioconductor-data-package? pkg) + (bioconductor-experiment-package? pkg)))) (import latest-bioconductor-release))) ;;; cran.scm ends here -- cgit v1.2.3 From 389c6082a440238accdd4e2df864135004dbb806 Mon Sep 17 00:00:00 2001 From: Ricardo Wurmus Date: Mon, 22 Jan 2024 12:44:46 +0100 Subject: import/cran: Set HOME when ExperimentHub is among the inputs. * guix/import/cran.scm (phases-for-inputs): Add 'set-HOME phase when ExperimentHub is among inputs. Change-Id: Ie3a2443934704eed8694a76a651b806209722421 --- guix/import/cran.scm | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/import/cran.scm b/guix/import/cran.scm index d49bd96c9a..db9250faec 100644 --- a/guix/import/cran.scm +++ b/guix/import/cran.scm @@ -677,7 +677,9 @@ of META, a package in REPOSITORY." of package names for all input packages." (let ((rules (list (lambda () - (and (member "styler" input-names) + (and (any (lambda (name) + (member name '("styler" "ExperimentHub"))) + input-names) '(add-after 'unpack 'set-HOME (lambda _ (setenv "HOME" "/tmp"))))) (lambda () -- cgit v1.2.3 From 916fb5347ab8d441e92ec6bfb13f9e9fef524ff7 Mon Sep 17 00:00:00 2001 From: Romain GARBAGE Date: Mon, 22 Jan 2024 11:32:55 +0100 Subject: guix: download: Add support for git repositories. * guix/scripts/download.scm (git-download-to-store*): Add new variable. (copy-recursively-without-dot-git): New variable. (git-download-to-file): Add new variable. (show-help): Add 'git', 'commit', 'branch' and 'recursive'options help message. (%default-options): Add default value for 'git-reference' and 'recursive' options. (%options): Add 'git', 'commit', 'branch' and 'recursive' command line options. (guix-download) [hash]: Compute hash with 'file-hash*' instead of 'port-hash' from (gcrypt hash) module. This allows us to compute hashes for directories. * doc/guix.texi (Invoking guix-download): Add @item entries for `git', `commit', `branch' and `recursive' options. Add a paragraph in the introduction. * tests/guix-download.sh: New tests. Move variables and trap definition to the top of the file. Change-Id: Ic2c428dca4cfcb0d4714ed361a4c46609339140a Signed-off-by: Maxim Cournoyer Reviewed-by: Maxim Cournoyer --- guix/scripts/download.scm | 167 +++++++++++++++++++++++++++++++++++++++++++--- 1 file changed, 156 insertions(+), 11 deletions(-) (limited to 'guix') diff --git a/guix/scripts/download.scm b/guix/scripts/download.scm index 19052d5652..de68e6f328 100644 --- a/guix/scripts/download.scm +++ b/guix/scripts/download.scm @@ -22,17 +22,24 @@ #:use-module (guix scripts) #:use-module (guix store) #:use-module (gcrypt hash) + #:use-module (guix hash) #:use-module (guix base16) #:use-module (guix base32) #:autoload (guix base64) (base64-encode) #:use-module ((guix download) #:hide (url-fetch)) + #:use-module ((guix git) + #:select (latest-repository-commit + update-cached-checkout + with-git-error-handling)) #:use-module ((guix build download) #:select (url-fetch)) + #:use-module (guix build utils) #:use-module ((guix progress) #:select (current-terminal-columns)) #:use-module ((guix build syscalls) #:select (terminal-columns)) #:use-module (web uri) + #:use-module (ice-9 ftw) #:use-module (ice-9 match) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) @@ -54,6 +61,57 @@ (url-fetch url file #:mirrors %mirrors))) file)) +;; This is a simplified version of 'copy-recursively'. +;; It allows us to filter out the ".git" subfolder. +;; TODO: Remove when 'copy-recursively' supports '#:select?'. +(define (copy-recursively-without-dot-git source destination) + (define strip-source + (let ((len (string-length source))) + (lambda (file) + (substring file len)))) + + (file-system-fold (lambda (file stat result) ; enter? + (not (string-suffix? "/.git" file))) + (lambda (file stat result) ; leaf + (let ((dest (string-append destination + (strip-source file)))) + (case (stat:type stat) + ((symlink) + (let ((target (readlink file))) + (symlink target dest))) + (else + (copy-file file dest))))) + (lambda (dir stat result) ; down + (let ((target (string-append destination + (strip-source dir)))) + (mkdir-p target))) + (const #t) ; up + (const #t) ; skip + (lambda (file stat errno result) + (format (current-error-port) "i/o error: ~a: ~a~%" + file (strerror errno)) + #f) + #t + source)) + +(define (git-download-to-file url file reference recursive?) + "Download the git repo at URL to file, checked out at REFERENCE. +REFERENCE must be a pair argument as understood by 'latest-repository-commit'. +Return FILE." + ;; 'libgit2' doesn't support the URL format generated by 'uri->string' so + ;; we have to do a little fixup. Dropping completely the 'file:' protocol + ;; part gives better performance. + (let ((url (cond ((string-prefix? "file://" url) + (string-drop url (string-length "file://"))) + ((string-prefix? "file:" url) + (string-drop url (string-length "file:"))) + (else url)))) + (copy-recursively-without-dot-git + (with-git-error-handling + (update-cached-checkout url #:ref reference #:recursive? recursive?)) + file)) + file) + (define (ensure-valid-store-file-name name) "Replace any character not allowed in a store name by an underscore." @@ -67,17 +125,46 @@ name)) -(define* (download-to-store* url #:key (verify-certificate? #t)) +(define* (download-to-store* url + #:key (verify-certificate? #t) + #:allow-other-keys) (with-store store (download-to-store store url (ensure-valid-store-file-name (basename url)) #:verify-certificate? verify-certificate?))) +(define* (git-download-to-store* url + reference + recursive? + #:key (verify-certificate? #t)) + "Download the git repository at URL to the store, checked out at REFERENCE. +URL must specify a protocol (i.e https:// or file://), REFERENCE must be a +pair argument as understood by 'latest-repository-commit'." + ;; Ensure the URL string is properly formatted when using the 'file' + ;; protocol: URL is generated using 'uri->string', which returns + ;; "file:/path/to/file" instead of "file:///path/to/file", which in turn + ;; makes 'git-download-to-store' fail. + (let* ((file? (string-prefix? "file:" url)) + (url (if (and file? + (not (string-prefix? "file:///" url))) + (string-append "file://" + (string-drop url (string-length "file:"))) + url))) + (with-store store + ;; TODO: Verify certificate support and deactivation. + (with-git-error-handling + (latest-repository-commit store + url + #:recursive? recursive? + #:ref reference))))) + (define %default-options ;; Alist of default option values. `((format . ,bytevector->nix-base32-string) (hash-algorithm . ,(hash-algorithm sha256)) (verify-certificate? . #t) + (git-reference . #f) + (recursive? . #f) (download-proc . ,download-to-store*))) (define (show-help) @@ -97,6 +184,19 @@ and 'base16' ('hex' and 'hexadecimal' can be used as well).\n")) do not validate the certificate of HTTPS servers ")) (format #t (G_ " -o, --output=FILE download to FILE")) + (format #t (G_ " + -g, --git download the default branch's latest commit of the + Git repository at URL")) + (format #t (G_ " + --commit=COMMIT-OR-TAG + download the given commit or tag of the Git + repository at URL")) + (format #t (G_ " + --branch=BRANCH download the given branch of the Git repository + at URL")) + (format #t (G_ " + -r, --recursive download a Git repository recursively")) + (newline) (display (G_ " -h, --help display this help and exit")) @@ -105,6 +205,13 @@ and 'base16' ('hex' and 'hexadecimal' can be used as well).\n")) (newline) (show-bug-report-information)) +(define (add-git-download-option result) + (alist-cons 'download-proc + ;; XXX: #:verify-certificate? currently ignored. + (lambda* (url #:key verify-certificate? ref recursive?) + (git-download-to-store* url ref recursive?)) + (alist-delete 'download result))) + (define %options ;; Specifications of the command-line options. (list (option '(#\f "format") #t #f @@ -136,10 +243,46 @@ and 'base16' ('hex' and 'hexadecimal' can be used as well).\n")) (alist-cons 'verify-certificate? #f result))) (option '(#\o "output") #t #f (lambda (opt name arg result) - (alist-cons 'download-proc - (lambda* (url #:key verify-certificate?) - (download-to-file url arg)) - (alist-delete 'download result)))) + (let* ((git + (assoc-ref result 'git-reference))) + (if git + (alist-cons 'download-proc + (lambda* (url + #:key + verify-certificate? + ref + recursive?) + (git-download-to-file + url + arg + (assoc-ref result 'git-reference) + recursive?)) + (alist-delete 'download result)) + (alist-cons 'download-proc + (lambda* (url + #:key verify-certificate? + #:allow-other-keys) + (download-to-file url arg)) + (alist-delete 'download result)))))) + (option '(#\g "git") #f #f + (lambda (opt name arg result) + ;; Ignore this option if 'commit' or 'branch' has + ;; already been provided + (if (assoc-ref result 'git-reference) + result + (alist-cons 'git-reference '() + (add-git-download-option result))))) + (option '("commit") #t #f + (lambda (opt name arg result) + (alist-cons 'git-reference `(tag-or-commit . ,arg) + (add-git-download-option result)))) + (option '("branch") #t #f + (lambda (opt name arg result) + (alist-cons 'git-reference `(branch . ,arg) + (add-git-download-option result)))) + (option '(#\r "recursive") #f #f + (lambda (opt name arg result) + (alist-cons 'recursive? #t result))) (option '(#\h "help") #f #f (lambda args @@ -183,12 +326,14 @@ and 'base16' ('hex' and 'hexadecimal' can be used as well).\n")) (terminal-columns))) (fetch (uri->string uri) #:verify-certificate? - (assq-ref opts 'verify-certificate?)))) - (hash (call-with-input-file - (or path - (leave (G_ "~a: download failed~%") - arg)) - (cute port-hash (assoc-ref opts 'hash-algorithm) <>))) + (assq-ref opts 'verify-certificate?) + #:ref (assq-ref opts 'git-reference) + #:recursive? (assq-ref opts 'recursive?)))) + (hash (let* ((path* (or path + (leave (G_ "~a: download failed~%") + arg)))) + (file-hash* path* + #:algorithm (assoc-ref opts 'hash-algorithm)))) (fmt (assq-ref opts 'format))) (format #t "~a~%~a~%" path (fmt hash)) #t))) -- cgit v1.2.3 From 6cca8f069431f4475d8eaf9336cb952ce5694e55 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Mon, 15 Jan 2024 18:18:36 +0100 Subject: =?UTF-8?q?weather:=20Add=20=E2=80=98-e=E2=80=99.?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * guix/scripts/weather.scm (show-help, %options): Add ‘-e’. (guix-weather): Handle it. * doc/guix.texi (Invoking guix weather): Document it. Change-Id: I6dc97ec2b8226b57be33247b05a34c23b573a64f --- guix/scripts/weather.scm | 9 ++++++++- 1 file changed, 8 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/scripts/weather.scm b/guix/scripts/weather.scm index 2f8985593d..08a1b22a74 100644 --- a/guix/scripts/weather.scm +++ b/guix/scripts/weather.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2017-2023 Ludovic Courtès +;;; Copyright © 2017-2024 Ludovic Courtès ;;; Copyright © 2017 Ricardo Wurmus ;;; Copyright © 2018 Kyle Meyer ;;; Copyright © 2020 Simon Tournier @@ -388,6 +388,8 @@ Report the availability of substitutes.\n")) -m, --manifest=MANIFEST look up substitutes for packages specified in MANIFEST")) (display (G_ " + -e, --expression=EXPR build the object EXPR evaluates to")) + (display (G_ " -c, --coverage[=COUNT] show substitute coverage for packages with at least COUNT dependents")) @@ -426,6 +428,9 @@ Report the availability of substitutes.\n")) (option '(#\m "manifest") #t #f (lambda (opt name arg result) (alist-cons 'manifest arg result))) + (option '(#\e "expression") #t #f + (lambda (opt name arg result) + (alist-cons 'expression arg result))) (option '(#\c "coverage") #f #t (lambda (opt name arg result) (alist-cons 'coverage @@ -611,6 +616,8 @@ SERVER. Display information for packages with at least THRESHOLD dependents." (base (filter-map (match-lambda (('argument . spec) (specification->package spec)) + (('expression . str) + (read/eval-package-expression str)) (_ #f)) opts))) -- cgit v1.2.3 From f8e0e5274fcf9c966b3938d32922b569f48de524 Mon Sep 17 00:00:00 2001 From: Sergey Trofimov Date: Tue, 23 Jan 2024 08:25:44 +0100 Subject: scripts: describe: Support 'channels-sans-intro' format for local checkouts. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * guix/scripts/describe.scm (%display-checkout-info): Support 'channels-sans-intro' format. Signed-off-by: Ludovic Courtès --- guix/scripts/describe.scm | 2 ++ 1 file changed, 2 insertions(+) (limited to 'guix') diff --git a/guix/scripts/describe.scm b/guix/scripts/describe.scm index 6d451dc902..449ab4b252 100644 --- a/guix/scripts/describe.scm +++ b/guix/scripts/describe.scm @@ -168,6 +168,8 @@ string is ~a.~%") (format #t (G_ " commit: ~a~%") (channel-commit channel))) ('channels (pretty-print `(list ,(channel->code channel)))) + ('channels-sans-intro + (pretty-print `(list ,(channel->code channel #:include-introduction? #f)))) ('json (display (channel->json channel)) (newline)) -- cgit v1.2.3 From 323b58ac18af8417d5b206288d09d9bb9385d7ae Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Wed, 31 Jan 2024 08:29:30 +0100 Subject: =?UTF-8?q?channels:=20=E2=80=98latest-channel-instances=E2=80=99?= =?UTF-8?q?=20traverses=20user-provided=20channels=20first.?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Previously, ‘latest-channel-instances’ would perform a depth-first traversal of channels. Since dependencies specified in ‘.guix-channel’ are usually less specific that those provided by the user, this would lead to the use of instances corresponding to those less specific specs, which in turn might declare dependencies that do not exist for the more specific instances. This commit changes ‘latest-channel-instances’ to perform a breadth-first traversal, thereby giving user-supplied channels higher precedence over dependencies found via ‘.guix-channel’. Fixes . * guix/channels.scm (latest-channel-instances)[ignore?]: Remove. [instance-name, same-named?, more-specific?]: New procedures. Rewrite as a breadth-first traversal using a regular loop. * tests/channels.scm ("latest-channel-instances reads dependencies from most-specific instance"): New test. Change-Id: Iba518145cfd209f04293a56246dbfee3b714650b --- guix/channels.scm | 132 ++++++++++++++++++++++++++++-------------------------- 1 file changed, 69 insertions(+), 63 deletions(-) (limited to 'guix') diff --git a/guix/channels.scm b/guix/channels.scm index f01903642d..1b07eb5221 100644 --- a/guix/channels.scm +++ b/guix/channels.scm @@ -34,7 +34,6 @@ #:use-module (guix packages) #:use-module (guix progress) #:use-module (guix derivations) - #:use-module (guix combinators) #:use-module (guix diagnostics) #:use-module (guix sets) #:use-module (guix store) @@ -510,16 +509,6 @@ CURRENT-CHANNELS is the list of currently used channels. It is compared against the newly-fetched instances of CHANNELS, and VALIDATE-PULL is called for each channel update and can choose to emit warnings or raise an error, depending on the policy it implements." - ;; Only process channels that are unique, or that are more specific than a - ;; previous channel specification. - (define (ignore? channel others) - (member channel others - (lambda (a b) - (and (eq? (channel-name a) (channel-name b)) - (or (channel-commit b) - (not (or (channel-commit a) - (channel-commit b)))))))) - (define (current-commit name) ;; Return the current commit for channel NAME. (any (lambda (channel) @@ -527,60 +516,77 @@ depending on the policy it implements." (channel-commit channel))) current-channels)) + (define instance-name + (compose channel-name channel-instance-channel)) + + (define (same-named? channel) + (let ((name (channel-name channel))) + (lambda (candidate) + (eq? (channel-name candidate) name)))) + + (define (more-specific? a b) + ;; A is more specific than B if it specifies a commit. + (and (channel-commit a) + (not (channel-commit b)))) + (let loop ((channels channels) - (previous-channels '())) - ;; Accumulate a list of instances. A list of processed channels is also - ;; accumulated to decide on duplicate channel specifications. - (define-values (resulting-channels instances) - (fold2 (lambda (channel previous-channels instances) - (if (ignore? channel previous-channels) - (values previous-channels instances) - (begin - (format (current-error-port) - (G_ "Updating channel '~a' from Git repository at '~a'...~%") - (channel-name channel) - (channel-url channel)) - (let* ((current (current-commit (channel-name channel))) - (instance - (latest-channel-instance store channel - #:authenticate? - authenticate? - #:validate-pull - validate-pull - #:starting-commit - current))) - (when authenticate? - ;; CHANNEL is authenticated so we can trust the - ;; primary URL advertised in its metadata and warn - ;; about possibly stale mirrors. - (let ((primary-url (channel-instance-primary-url - instance))) - (unless (or (not primary-url) - (channel-commit channel) - (string=? primary-url (channel-url channel))) - (warning (G_ "pulled channel '~a' from a mirror \ + (previous-channels '()) + (instances '())) + (match channels + (() + (reverse instances)) + ((channel . rest) + (let ((previous (find (same-named? channel) previous-channels))) + ;; If there's already an instance for CHANNEL, keep the most specific + ;; one. + (if (and previous + (not (more-specific? channel previous))) + (loop rest previous-channels instances) + (begin + (format (current-error-port) + (G_ "Updating channel '~a' from Git repository at '~a'...~%") + (channel-name channel) + (channel-url channel)) + (let* ((current (current-commit (channel-name channel))) + (instance + (latest-channel-instance store channel + #:authenticate? + authenticate? + #:validate-pull + validate-pull + #:starting-commit + current))) + (when authenticate? + ;; CHANNEL is authenticated so we can trust the + ;; primary URL advertised in its metadata and warn + ;; about possibly stale mirrors. + (let ((primary-url (channel-instance-primary-url + instance))) + (unless (or (not primary-url) + (channel-commit channel) + (string=? primary-url (channel-url channel))) + (warning (G_ "pulled channel '~a' from a mirror \ of ~a, which might be stale~%") - (channel-name channel) - primary-url)))) - - (let-values (((new-instances new-channels) - (loop (channel-instance-dependencies instance) - previous-channels))) - (values (append (cons channel new-channels) - previous-channels) - (append (cons instance new-instances) - instances))))))) - previous-channels - '() ;instances - channels)) - - (let ((instance-name (compose channel-name channel-instance-channel))) - ;; Remove all earlier channel specifications if they are followed by a - ;; more specific one. - (values (delete-duplicates instances - (lambda (a b) - (eq? (instance-name a) (instance-name b)))) - resulting-channels)))) + (channel-name channel) + primary-url)))) + + ;; Perform a breadth-first traversal with the idea that the + ;; user-provided channels may be more specific than what + ;; '.guix-channel' specifies, and so it is on those instances + ;; that 'channel-instance-dependencies' should be called. + (loop (append rest + (channel-instance-dependencies instance)) + (cons channel + (if previous + (delq previous previous-channels) + previous-channels)) + (cons instance + (if previous + (remove (lambda (instance) + (eq? (instance-name instance) + (channel-name channel))) + instances) + instances))))))))))) (define* (checkout->channel-instance checkout #:key commit -- cgit v1.2.3 From 4cc7302e7dcd1de8d5ca7e9b82da2f8b9fa98911 Mon Sep 17 00:00:00 2001 From: Christopher Baines Date: Sat, 10 Feb 2024 10:33:18 +0000 Subject: build-system: perl: Accept Gexps for #:module-build-flags. Matching the change in 2d40e6f7ab04ec367a9a7fc1af3daa507fb60d3c otherwise the cross build derivations are broken, as was the case for emacs-pde. * guix/build-system/perl.scm (perl-cross-build) [module-build-flags]: Accept gexps. Change-Id: I2dc85bc50bc077581e3abfc5baaedc6487118192 --- guix/build-system/perl.scm | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/build-system/perl.scm b/guix/build-system/perl.scm index 0d5493ab90..3f7a2dea27 100644 --- a/guix/build-system/perl.scm +++ b/guix/build-system/perl.scm @@ -197,7 +197,9 @@ XS or similar." native-search-paths)) #:make-maker? #$make-maker? #:make-maker-flags #$make-maker-flags - #:module-build-flags #$(sexp->gexp module-build-flags) + #:module-build-flags #$(if (pair? module-build-flags) + (sexp->gexp module-build-flags) + module-build-flags) #:phases #$phases #:build #$build #:system #$system -- cgit v1.2.3 From 5bd5bb5f6ca822f76599ca6d1959f4c42d4bc222 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Mon, 12 Feb 2024 11:41:43 +0100 Subject: git authenticate: Gracefully handle invalid fingerprints. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Previously the command would crash when passed an invalid fingerprint on the command line. * guix/scripts/git/authenticate.scm (guix-git-authenticate) [openpgp-fingerprint*]: New procedure. Use it instead of ‘openpgp-fingerprint’. Change-Id: I99e0549781382f36a684a84449b603e00b53778d --- guix/scripts/git/authenticate.scm | 15 +++++++++++++-- 1 file changed, 13 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/scripts/git/authenticate.scm b/guix/scripts/git/authenticate.scm index 5f5d423f28..6ff5cee682 100644 --- a/guix/scripts/git/authenticate.scm +++ b/guix/scripts/git/authenticate.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2020 Ludovic Courtès +;;; Copyright © 2020, 2024 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -27,6 +27,7 @@ #:use-module ((guix git) #:select (with-git-error-handling)) #:use-module (guix progress) #:use-module (guix base64) + #:autoload (rnrs bytevectors) (bytevector-length) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) #:use-module (srfi srfi-37) @@ -133,6 +134,16 @@ Authenticate the given Git checkout using COMMIT/SIGNER as its introduction.\n") (define commit-short-id (compose (cut string-take <> 7) oid->string commit-id)) + (define (openpgp-fingerprint* str) + (unless (string-every (char-set-union char-set:hex-digit + char-set:whitespace) + str) + (leave (G_ "~a: invalid OpenPGP fingerprint~%") str)) + (let ((fingerprint (openpgp-fingerprint str))) + (unless (= 20 (bytevector-length fingerprint)) + (leave (G_ "~a: wrong length for OpenPGP fingerprint~%") str)) + fingerprint)) + (define (make-reporter start-commit end-commit commits) (format (current-error-port) (G_ "Authenticating commits ~a to ~a (~h new \ @@ -165,7 +176,7 @@ commits)...~%") (repository-cache-key repository)))) (define stats (authenticate-repository repository (string->oid commit) - (openpgp-fingerprint signer) + (openpgp-fingerprint* signer) #:end end #:keyring-reference keyring #:historical-authorizations history -- cgit v1.2.3 From 1610a632d4b3097282d18af27ff3e9e178d7dfcb Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Thu, 25 Jan 2024 22:40:48 +0100 Subject: =?UTF-8?q?swh:=20=E2=80=98vault-fetch=E2=80=99=20follows=20redire?= =?UTF-8?q?cts.?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Today, URLs like https://archive.softwareheritage.org/api/1/vault/flat/swh:1:dir:84a8b34591712c0a90bab0af604188bcd1fe3153/raw/ redirect to https://swhvaultstorage.blob.core.windows.net/…. This change fixes ‘vault-fetch’ to follow these. Fixes . * guix/swh.scm (http-get/follow): New procedure. (vault-fetch): Use it instead of ‘http-get*’. Change-Id: Id6b9585a9ce6699a2274b99c9a6d4edda1018b02 --- guix/swh.scm | 52 +++++++++++++++++++++++++++++++++++++++++----------- 1 file changed, 41 insertions(+), 11 deletions(-) (limited to 'guix') diff --git a/guix/swh.scm b/guix/swh.scm index c7c1c873a2..4e71bdb045 100644 --- a/guix/swh.scm +++ b/guix/swh.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 ;;; Copyright © 2020 Jakub Kądziołka ;;; Copyright © 2021 Xinglu Chen ;;; Copyright © 2021 Simon Tournier @@ -583,6 +583,41 @@ directory identifier is deprecated." json->vault-reply http-post*)) +(define* (http-get/follow url + #:key + (verify-certificate? (%verify-swh-certificate?))) + "Like 'http-get' but follow redirects (HTTP 30x). On success, return two +values: an input port to read the response body and its 'Content-Length'. On +failure return #f and #f." + (define uri + (if (string? url) (string->uri url) url)) + + (let loop ((uri uri)) + (define (resolve-uri-reference target) + (if (and (uri-scheme target) (uri-host target)) + target + (build-uri (uri-scheme uri) #:host (uri-host uri) + #:port (uri-port uri) + #:path (uri-path target)))) + + (let*-values (((response port) + (http-get* uri #:streaming? #t + #:verify-certificate? verify-certificate?)) + ((code) + (response-code response))) + (case code + ((200) + (values port (response-content-length response))) + ((301 ; moved permanently + 302 ; found (redirection) + 303 ; see other + 307 ; temporary redirection + 308) ; permanent redirection + (close-port port) + (loop (resolve-uri-reference (response-location response)))) + (else + (values #f #f)))))) + (define* (vault-fetch id #:optional kind #:key @@ -604,16 +639,11 @@ for a tarball containing a bare Git repository corresponding to a revision." (match (vault-reply-status reply) ('done ;; Fetch the bundle. - (let-values (((response port) - (http-get* (swh-url (vault-reply-fetch-url reply)) - #:streaming? #t - #:verify-certificate? - (%verify-swh-certificate?)))) - (if (= (response-code response) 200) - port - (begin ;shouldn't happen - (close-port port) - #f)))) + (let-values (((port length) + (http-get/follow (swh-url (vault-reply-fetch-url reply)) + #:verify-certificate? + (%verify-swh-certificate?)))) + port)) ('failed ;; Upon failure, we're supposed to try again. (format log-port "SWH vault: failure: ~a~%" -- cgit v1.2.3 From be773bd192466fa7e26938a157c0885adf46139e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Thu, 25 Jan 2024 22:53:56 +0100 Subject: =?UTF-8?q?swh:=20Add=20bindings=20for=20the=20=E2=80=9CExtID?= =?UTF-8?q?=E2=80=9D=20API.?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit This interface was deployed at archive.softwareheritage.org a few days ago. Our main use case will be looking up directories by “nar-sha256” hashes. * guix/swh.scm (): New JSON-mapped record type. (lookup-external-id, lookup-directory-by-nar-hash): New procedures. * tests/swh.scm (%external-id): New variable. ("lookup-directory-by-nar-hash"): New test. Change-Id: Ib671c7798aeb6f8132ac78f2b06b9285da8e7bd5 --- guix/swh.scm | 35 +++++++++++++++++++++++++++++++++++ 1 file changed, 35 insertions(+) (limited to 'guix') diff --git a/guix/swh.scm b/guix/swh.scm index 4e71bdb045..60e97c6d38 100644 --- a/guix/swh.scm +++ b/guix/swh.scm @@ -78,6 +78,14 @@ lookup-revision lookup-origin-revision + external-id? + external-id-value + external-id-type + external-id-version + external-id-target + lookup-external-id + lookup-directory-by-nar-hash + content? content-checksums content-data-url @@ -382,6 +390,15 @@ FALSE-IF-404? is true, return #f upon 404 responses." (permissions directory-entry-permissions "perms") (target-url directory-entry-target-url "target_url")) +;; +(define-json-mapping make-external-id external-id? + json->external-id + (value external-id-value "extid") + (type external-id-type "extid_type") + (version external-id-version "extid_version") + (target external-id-target) + (target-url external-id-target-url "target_url")) + ;; (define-json-mapping make-save-reply save-reply? json->save-reply @@ -436,6 +453,24 @@ FALSE-IF-404? is true, return #f upon 404 responses." (map json->directory-entry (vector->list (json->scm port)))) +(define (lookup-external-id type id) + "Return the external ID record for ID, a bytevector, of the given TYPE +(currently one of: \"bzr-nodeid\", \"hg-nodeid\", \"nar-sha256\", +\"checksum-sha512\")." + (call (swh-url "/api/1/extid" type + (string-append "hex:" (bytevector->base16-string id))) + json->external-id)) + +(define* (lookup-directory-by-nar-hash hash #:optional (algorithm 'sha256)) + "Return the SWHID of a directory---i.e., prefixed by \"swh:1:dir\"---for the +directory that with the given HASH (a bytevector), assuming nar serialization +and use of ALGORITHM." + ;; example: + ;; https://archive.softwareheritage.org/api/1/extid/nar-sha256/base64url:0jD6Z4TLMm5g1CviuNNuVNP31KWyoT_oevfr8TQwc3Y/ + (and=> (lookup-external-id (string-append "nar-" (symbol->string algorithm)) + hash) + external-id-target)) + (define (origin-visits origin) "Return the list of visits of ORIGIN, a record as returned by 'lookup-origin'." -- cgit v1.2.3 From 1b72e1430794fd09bb2be1d72f482a40c0f9196e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Thu, 25 Jan 2024 23:27:51 +0100 Subject: =?UTF-8?q?swh:=20Add=20=E2=80=98swh-download-directory-by-nar-has?= =?UTF-8?q?h=E2=80=99.?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit This allows us to take advantage of content addressing by giving SWH the expected nar hash. * guix/swh.scm (swh-download-directory-by-nar-hash): New procedure. Change-Id: I0494ee15a3cde390a22552de7c2246e0314ba7b5 --- guix/swh.scm | 24 ++++++++++++++++++++++++ 1 file changed, 24 insertions(+) (limited to 'guix') diff --git a/guix/swh.scm b/guix/swh.scm index 60e97c6d38..be1eb7d151 100644 --- a/guix/swh.scm +++ b/guix/swh.scm @@ -123,6 +123,7 @@ commit-id? swh-download-directory + swh-download-directory-by-nar-hash swh-download)) ;;; Commentary: @@ -805,3 +806,26 @@ wait until it becomes available, which could take several minutes." "SWH: revision ~s originating from ~a could not be found~%" reference url) #f))) + +(define* (swh-download-directory-by-nar-hash hash algorithm output + #:key + (log-port (current-error-port))) + "Download from Software Heritage the directory with the given nar HASH for +ALGORITHM (a symbol such as 'sha256), and unpack it in OUTPUT. Return #t on +success and #f on failure. + +This procedure uses the \"vault\", which contains \"cooked\" directories in +the form of tarballs. If the requested directory is not cooked yet, it will +wait until it becomes available, which could take several minutes." + (match (lookup-directory-by-nar-hash hash algorithm) + (#f + (format log-port + "SWH: directory with nar-~a hash ~a not found~%" + algorithm (bytevector->base16-string hash)) + #f) + (swhid + (format log-port "SWH: found directory with nar-~a hash ~a at '~a'~%" + algorithm (bytevector->base16-string hash) swhid) + (swh-download-archive swhid output + #:archive-type 'flat ;SWHID denotes a directory + #:log-port log-port)))) -- cgit v1.2.3 From 29f3089c841f00144f24f5c32296aebf22d752cc Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Fri, 26 Jan 2024 14:41:37 +0100 Subject: =?UTF-8?q?lint:=20archival:=20Check=20with=20=E2=80=98lookup-dire?= =?UTF-8?q?ctory-by-nar-hash=E2=80=99.?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit While this method is new and nar-sha256 ExtIDs are currently available only for new visits, it is fundamentally more reliable than the other methods, which is why it comes first. * guix/lint.scm (check-archival)[lookup-by-nar-hash]: New procedure. Call ‘lookup-by-nar-hash’ before the other lookup methods. * tests/lint.scm ("archival: content available") ("archival: content unavailable but disarchive available") ("archival: missing revision") ("archival: revision available"): Add a 404 response corresponding to the ‘lookup-external-id’ request. * tests/lint.scm ("archival: nar-sha256 extid available"): New test. Change-Id: I4a81d6e022a3b72e6484726549d7fbae627f8e73 --- guix/lint.scm | 30 +++++++++++++++++++----------- 1 file changed, 19 insertions(+), 11 deletions(-) (limited to 'guix') diff --git a/guix/lint.scm b/guix/lint.scm index 861e352b93..c95de85e69 100644 --- a/guix/lint.scm +++ b/guix/lint.scm @@ -1,7 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2014 Cyril Roelandt ;;; Copyright © 2014, 2015 Eric Bavier -;;; Copyright © 2013-2023 Ludovic Courtès +;;; Copyright © 2013-2024 Ludovic Courtès ;;; Copyright © 2015, 2016 Mathieu Lirzin ;;; Copyright © 2016 Danny Milosavljevic ;;; Copyright © 2016 Hartmut Goebel @@ -1658,24 +1658,31 @@ try again later") (or (not (request-rate-limit-reached? url method)) (throw skip-key #t))) + (define (lookup-by-nar-hash hash) + (lookup-directory-by-nar-hash (content-hash-value hash) + (content-hash-algorithm hash))) + (parameterize ((%allow-request? skip-when-limit-reached)) (catch #t (lambda () (match (package-source package) (#f ;no source '()) - ((and (? origin?) + ((and (? origin? origin) (= origin-uri (? git-reference? reference))) (define url (git-reference-url reference)) (define commit (git-reference-commit reference)) - - (match (if (commit-id? commit) - (or (lookup-revision commit) - (lookup-origin-revision url commit)) - (lookup-origin-revision url commit)) - ((? revision? revision) + (define hash + (origin-hash origin)) + + (match (or (lookup-by-nar-hash hash) + (if (commit-id? commit) + (or (lookup-revision commit) + (lookup-origin-revision url commit)) + (lookup-origin-revision url commit))) + ((or (? string?) (? revision?)) '()) (#f ;; Revision is missing from the archive, attempt to save it. @@ -1704,9 +1711,10 @@ try again later") (if (and=> (origin-hash origin) ;XXX: for ungoogled-chromium content-hash-value) ;& icecat (let ((hash (origin-hash origin))) - (match (lookup-content (content-hash-value hash) - (symbol->string - (content-hash-algorithm hash))) + (match (or (lookup-by-nar-hash hash) + (lookup-content (content-hash-value hash) + (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 -- cgit v1.2.3 From 264fdbcaff9c078642355bace0c61c094b3581fc Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Fri, 26 Jan 2024 17:27:11 +0100 Subject: git-download: Download from SWH by nar hash when possible. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * guix/build/git.scm (git-fetch-with-fallback): Add #:hash and #:hash-algorithm. Try ‘swh-download-directory-by-nar-hash’ before ‘swh-download’ when #:hash is provided. * guix/git-download.scm (git-fetch/in-band*): Pass #:hash and #:hash-algorithm to ‘git-fetch-with-fallback’. * guix/scripts/perform-download.scm (perform-git-download): Likewise. Change-Id: Ic875a7022fd78c9fac32e92ad4f8ce4d81646ec5 --- guix/build/git.scm | 20 ++++++++++++++++---- guix/git-download.scm | 4 +++- guix/scripts/perform-download.scm | 4 +++- 3 files changed, 22 insertions(+), 6 deletions(-) (limited to 'guix') diff --git a/guix/build/git.scm b/guix/build/git.scm index 867cade2c4..4c69365a7b 100644 --- a/guix/build/git.scm +++ b/guix/build/git.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2014, 2016, 2019, 2023 Ludovic Courtès +;;; Copyright © 2014, 2016, 2019, 2023-2024 Ludovic Courtès ;;; Copyright © 2023 Maxim Cournoyer ;;; ;;; This file is part of GNU Guix. @@ -20,7 +20,9 @@ (define-module (guix build git) #:use-module (guix build utils) #:autoload (guix build download-nar) (download-nar) - #:autoload (guix swh) (%verify-swh-certificate? swh-download) + #:autoload (guix swh) (%verify-swh-certificate? + swh-download + swh-download-directory-by-nar-hash) #:use-module (srfi srfi-34) #:use-module (ice-9 format) #:export (git-fetch @@ -91,10 +93,13 @@ fetched, recursively. Return #t on success, #f otherwise." (define* (git-fetch-with-fallback url commit directory #:key (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." +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? @@ -110,7 +115,14 @@ and if that also fails, download from the Software Heritage archive." (format (current-error-port) "Trying to download from Software Heritage...~%") - (swh-download url commit directory) + ;; First try to look up and download the directory corresponding + ;; to HASH: this is fundamentally more reliable than looking up + ;; COMMIT, especially when COMMIT denotes a tag. + (or (and hash hash-algorithm + (swh-download-directory-by-nar-hash hash hash-algorithm + directory)) + (swh-download url commit directory)) + (when (file-exists? (string-append directory "/.gitattributes")) ;; Perform CR/LF conversion and other changes diff --git a/guix/git-download.scm b/guix/git-download.scm index 3de6ae970d..aadcbd234c 100644 --- a/guix/git-download.scm +++ b/guix/git-download.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2014-2021, 2023 Ludovic Courtès +;;; Copyright © 2014-2021, 2023-2024 Ludovic Courtès ;;; Copyright © 2017 Mathieu Lirzin ;;; Copyright © 2017 Christopher Baines ;;; Copyright © 2020 Jakub Kądziołka @@ -165,6 +165,8 @@ respective documentation." (git-fetch-with-fallback (getenv "git url") (getenv "git commit") #$output + #:hash #$hash + #:hash-algorithm '#$hash-algo #:lfs? lfs? #:recursive? recursive? #:git-command "git"))))) diff --git a/guix/scripts/perform-download.scm b/guix/scripts/perform-download.scm index 9aa0e61e9d..e7eb3b2a1f 100644 --- a/guix/scripts/perform-download.scm +++ b/guix/scripts/perform-download.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2016-2018, 2020, 2023 Ludovic Courtès +;;; Copyright © 2016-2018, 2020, 2023-2024 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -115,6 +115,8 @@ Note: OUTPUT may differ from the 'out' value of DRV, notably for 'bmCheck' or (setenv "PATH" "/run/current-system/profile/bin:/bin:/usr/bin") (git-fetch-with-fallback url commit output + #:hash hash + #:hash-algorithm algo #:recursive? recursive? #:git-command %git)))) -- cgit v1.2.3 From 5a61ce6bcfbd0882956e40457232da737776abe7 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Fri, 26 Jan 2024 17:38:12 +0100 Subject: =?UTF-8?q?swh:=20Fix=20docstring=20of=20=E2=80=98lookup-directory?= =?UTF-8?q?=E2=80=99.?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * guix/swh.scm (lookup-directory): Fix docstring. Change-Id: Ia1fd9b2bc9184364cebbd30ee84c9fdea4ba897c --- guix/swh.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/swh.scm b/guix/swh.scm index be1eb7d151..04cecd854c 100644 --- a/guix/swh.scm +++ b/guix/swh.scm @@ -446,7 +446,7 @@ FALSE-IF-404? is true, return #f upon 404 responses." json->revision) (define-query (lookup-directory id) - "Return the directory with the given ID." + "Return the list of entries of the directory with the given ID." (path "/api/1/directory" id) json->directory-entries) -- cgit v1.2.3 From 5f86eebd240958001ab4f178005f355d24d9b7f1 Mon Sep 17 00:00:00 2001 From: Timothy Sample Date: Thu, 25 Jan 2024 11:52:06 -0600 Subject: gnu: disarchive: Update to 0.6.0. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * gnu/packages/backup.scm (disarchive): Update to 0.6.0; add 'guile-bzip2' as an input. * gnu/packages/package-management.scm (guix): Add 'guile-bzip2' as an input to enable bzip2 support when using Disarchive. * guix/self.scm (%packages): Add 'guile-bzip2'. (compiled-guix): Include 'guile-bzip2' as a dependency when building the 'guix' command. * etc/disarchive-manifest.scm (tarball-origin?): Include bzip2 tarballs. Co-authored-by: Ludovic Courtès Change-Id: I4da479054f6bef225f5ea979c091152f8a9e51d5 --- guix/self.scm | 5 +++++ 1 file changed, 5 insertions(+) (limited to 'guix') diff --git a/guix/self.scm b/guix/self.scm index f378548959..19c6d08e01 100644 --- a/guix/self.scm +++ b/guix/self.scm @@ -65,6 +65,7 @@ ("guile-gnutls" . ,(ref 'tls 'guile-gnutls)) ("guix-daemon" . ,(ref 'package-management 'guix-daemon)) ("disarchive" . ,(ref 'backup 'disarchive)) + ("guile-bzip2" . ,(ref 'guile 'guile-bzip2)) ("guile-lzma" . ,(ref 'guile 'guile-lzma)) ("gzip" . ,(ref 'compression 'gzip)) ("bzip2" . ,(ref 'compression 'bzip2)) @@ -827,6 +828,9 @@ itself." (define disarchive (specification->package "disarchive")) + (define guile-bzip2 + (specification->package "guile-bzip2")) + (define guile-lzma (specification->package "guile-lzma")) @@ -1058,6 +1062,7 @@ itself." #:source source #:dependencies (cons* disarchive + guile-bzip2 guile-lzma dependencies) #:guile guile-for-build -- cgit v1.2.3 From 00c8a9275c67c08b6fb9058617d3ad7d55fa4fad Mon Sep 17 00:00:00 2001 From: Ricardo Wurmus Date: Mon, 19 Feb 2024 11:44:47 +0100 Subject: upstream: update-package-inputs: Sort extra inputs. Ensure that extra inputs end up in the correct order. * guix/upstream.scm (update-package-inputs)[filtered-inputs]: Sort new list of inputs. Change-Id: Ia5fddd8103a33c79426995057fcce61c2e9e5a72 --- guix/upstream.scm | 28 ++++++++++++++++------------ 1 file changed, 16 insertions(+), 12 deletions(-) (limited to 'guix') diff --git a/guix/upstream.scm b/guix/upstream.scm index e28ae12f3f..180ae21dcf 100644 --- a/guix/upstream.scm +++ b/guix/upstream.scm @@ -1,7 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2010-2023 Ludovic Courtès ;;; Copyright © 2015 Alex Kost -;;; Copyright © 2019, 2022, 2023 Ricardo Wurmus +;;; Copyright © 2019, 2022-2024 Ricardo Wurmus ;;; Copyright © 2021 Sarah Morgensen ;;; Copyright © 2021, 2022 Maxime Devos ;;; Copyright © 2022 Hartmut Goebel @@ -566,17 +566,21 @@ specified in SOURCE, an ." (properties (package-properties package)) (ignore (or (assoc-ref properties ignore-property) '())) (extra (or (assoc-ref properties extra-property) '()))) - (append (if (null? ignore) - inputs - (remove (lambda (input) - (member (upstream-input-downstream-name input) - ignore)) - inputs)) - (map (lambda (name) - (upstream-input - (name name) - (downstream-name name))) - extra))))) + (sort + (append (if (null? ignore) + inputs + (remove (lambda (input) + (member (upstream-input-downstream-name input) + ignore)) + inputs)) + (map (lambda (name) + (upstream-input + (name name) + (downstream-name name))) + extra)) + (lambda (a b) + (string-ci Date: Tue, 20 Feb 2024 10:32:24 +0100 Subject: import/cran: Use downstream name when using specifications. Reported by Alexander Blume at . * guix/import/cran.scm (format-inputs): Use UPSTREAM-INPUT-DOWNSTREAM-NAME when %INPUT-STYLE is set to 'SPECIFICATION. Change-Id: I2f0963af197896aafd613b253d8712e41a716e52 --- guix/import/cran.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/import/cran.scm b/guix/import/cran.scm index db9250faec..9b30dc30e0 100644 --- a/guix/import/cran.scm +++ b/guix/import/cran.scm @@ -90,7 +90,7 @@ (map (lambda (input) (case (%input-style) ((specification) - `(specification->package ,(upstream-input-name input))) + `(specification->package ,(upstream-input-downstream-name input))) (else ((compose string->symbol upstream-input-downstream-name) -- cgit v1.2.3 From 34c79c6ae8103ebae9ce08c81a9220a6b82b05f6 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Tue, 20 Feb 2024 10:46:42 +0100 Subject: =?UTF-8?q?syscalls:=20=E2=80=98processes=E2=80=99=20really=20omit?= =?UTF-8?q?s=20kernel=20threads.?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Fixes a bug whereby ‘processes’ would include kernel threads, thereby leading the ‘stop’ method of ‘user-processes’ to wait indefinitely for a kernel thread. Code taken from the Shepherd. Fixes . * guix/build/syscalls.scm (kernel?): Remove. (linux-process-flags, linux-kernel-thread?, pseudo-process?): New procedures. (PF_KTHREAD): New variable. (processes): Use ‘pseudo-process?’ instead of ‘kernel?’. Reported-by: Tomas Volf <~@wolfsden.cz> Change-Id: I8c439cdaf868a8f899de7fe500ce8bf10e5fc290 --- guix/build/syscalls.scm | 55 +++++++++++++++++++++++++++++++++++-------------- 1 file changed, 39 insertions(+), 16 deletions(-) (limited to 'guix') diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm index b2871c3c10..39bcffd516 100644 --- a/guix/build/syscalls.scm +++ b/guix/build/syscalls.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2014-2023 Ludovic Courtès +;;; Copyright © 2014-2024 Ludovic Courtès ;;; Copyright © 2015 David Thompson ;;; Copyright © 2015 Mark H Weaver ;;; Copyright © 2017 Mathieu Othacehe @@ -765,27 +765,50 @@ current process." (list (strerror err)) (list err))))))) -(define (kernel? pid) - "Return #t if PID designates a \"kernel thread\" rather than a normal -user-land process." - (let ((stat (call-with-input-file (format #f "/proc/~a/stat" pid) - (compose string-tokenize read-string)))) - ;; See proc.txt in Linux's documentation for the list of fields. - (match stat - ((pid tcomm state ppid pgrp sid tty_nr tty_pgrp flags min_flt - cmin_flt maj_flt cmaj_flt utime stime cutime cstime - priority nice num_thread it_real_value start_time - vsize rss rsslim - (= string->number start_code) (= string->number end_code) _ ...) - ;; Got this obscure trick from sysvinit's 'killall5' program. - (and (zero? start_code) (zero? end_code)))))) +(define (linux-process-flags pid) ;copied from the Shepherd + "Return the process flags of @var{pid} (or'd @code{PF_} constants), assuming +the Linux /proc file system is mounted; raise a @code{system-error} exception +otherwise." + (call-with-input-file (string-append "/proc/" (number->string pid) + "/stat") + (lambda (port) + (define line + (read-string port)) + + ;; Parse like systemd's 'is_kernel_thread' function. + (let ((offset (string-index line #\)))) ;offset past 'tcomm' field + (match (and offset + (string-tokenize (string-drop line (+ offset 1)))) + ((state ppid pgrp sid tty-nr tty-pgrp flags . _) + (or (string->number flags) 0)) + (_ + 0)))))) + +;; Per-process flag defined in . +(define PF_KTHREAD #x00200000) ;I am a kernel thread + +(define (linux-kernel-thread? pid) + "Return true if @var{pid} is a Linux kernel thread." + (= PF_KTHREAD (logand (linux-process-flags pid) PF_KTHREAD))) + +(define pseudo-process? + (if (string-contains %host-type "linux") + (lambda (pid) + "Return true if @var{pid} denotes a \"pseudo-process\" such as a Linux +kernel thread rather than a \"regular\" process. A pseudo-process is one that +may never terminate, even after sending it SIGKILL---e.g., kthreadd on Linux." + (catch 'system-error + (lambda () + (linux-kernel-thread? pid)) + (const #f))) + (const #f))) (define (processes) "Return the list of live processes." (sort (filter-map (lambda (file) (let ((pid (string->number file))) (and pid - (not (kernel? pid)) + (not (pseudo-process? pid)) pid))) (scandir "/proc")) <)) -- cgit v1.2.3 From e60ac989a3690998f5774b7093eb9720a8dba344 Mon Sep 17 00:00:00 2001 From: Efraim Flashner Date: Thu, 4 Jan 2024 10:57:25 +0200 Subject: build: cargo: Add support for x86_64-linux-gnux32. * guix/build/cargo-build-system.scm (configure): Add entry for x86_64-linux-gnux32 in CARGO_BUILD_TARGET. Change-Id: Iae363d4e7962af1ebd4f2ed0f4276663b2245580 --- guix/build/cargo-build-system.scm | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/build/cargo-build-system.scm b/guix/build/cargo-build-system.scm index ffb2ec898e..70ddf063d2 100644 --- a/guix/build/cargo-build-system.scm +++ b/guix/build/cargo-build-system.scm @@ -2,7 +2,7 @@ ;;; Copyright © 2016 David Craven ;;; Copyright © 2017 Mathieu Othacehe ;;; Copyright © 2019 Ivan Petkov -;;; Copyright © 2019-2023 Efraim Flashner +;;; Copyright © 2019-2024 Efraim Flashner ;;; Copyright © 2020 Jakub Kądziołka ;;; Copyright © 2020 Marius Bakke ;;; @@ -162,6 +162,7 @@ libraries or executables." ("powerpc64le-linux-gnu" "powerpc64le-unknown-linux-gnu") ("riscv64-linux-gnu" "riscv64gc-unknown-linux-gnu") ("x86_64-linux-gnu" "x86_64-unknown-linux-gnu") + ("x86_64-linux-gnux32" "x86_64-unknown-linux-gnux32") ("i586-pc-gnu" "i686-unknown-hurd-gnu") ("i686-w64-mingw32" "i686-pc-windows-gnu") ("x86_64-w64-mingw32" "x86_64-pc-windows-gnu") -- cgit v1.2.3 From a1d0610f830e1bf3573cac42ba4c013ed76accef Mon Sep 17 00:00:00 2001 From: Herman Rimm Date: Tue, 20 Feb 2024 21:45:10 +0100 Subject: import: Wrap package expressions with define-public. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * guix/scripts/import.scm (guix-import): Wrap package expressions. Change-Id: Ic4d986a4706a692b2fecd6fded8ac72ab6311687 Signed-off-by: Ludovic Courtès --- guix/scripts/import.scm | 14 +++++++++++--- 1 file changed, 11 insertions(+), 3 deletions(-) (limited to 'guix') diff --git a/guix/scripts/import.scm b/guix/scripts/import.scm index d2a1cee56e..77fcfe3990 100644 --- a/guix/scripts/import.scm +++ b/guix/scripts/import.scm @@ -6,6 +6,7 @@ ;;; Copyright © 2021 Simon Tournier ;;; Copyright © 2021 Xinglu Chen ;;; Copyright © 2022 Philip McGrath +;;; Copyright © 2024 Herman Rimm ;;; ;;; This file is part of GNU Guix. ;;; @@ -23,6 +24,7 @@ ;;; along with GNU Guix. If not, see . (define-module (guix scripts import) + #:use-module (guix import utils) #:use-module (guix ui) #:use-module (guix scripts) #:use-module (guix read-print) @@ -89,12 +91,18 @@ Run IMPORTER with ARGS.\n")) (pretty-print-with-comments (current-output-port) expr))))) (match (apply (resolve-importer importer) args) ((and expr (or ('package _ ...) - ('let _ ...) - ('define-public _ ...))) + ('let _ ...))) + (print (package->definition expr))) + ((and expr ('define-public _ ...)) (print expr)) ((? list? expressions) (for-each (lambda (expr) - (print expr) + (match expr + ((and expr (or ('package _ ...) + ('let _ ...))) + (print (package->definition expr))) + ((and expr ('define-public _ ...)) + (print expr))) ;; Two newlines: one after the closing paren, and ;; one to leave a blank line. (newline) (newline)) -- cgit v1.2.3 From babd39e84389c544e8dab44be8ddec57e52709c9 Mon Sep 17 00:00:00 2001 From: Herman Rimm Date: Tue, 20 Feb 2024 21:45:11 +0100 Subject: utils: Add insert-expression procedure. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * guix/utils.scm (define-module): Use (guix read-print) and export (insert-expression). (insert-expression): Add procedure. * tests/utils.scm ("insert-expression"): Add test. Change-Id: I971a43a78aa6ecaaef33c1a7a0db4b287eb85036 Signed-off-by: Ludovic Courtès --- guix/utils.scm | 11 +++++++++++ 1 file changed, 11 insertions(+) (limited to 'guix') diff --git a/guix/utils.scm b/guix/utils.scm index e4e9d922e7..94b4d753d0 100644 --- a/guix/utils.scm +++ b/guix/utils.scm @@ -20,6 +20,7 @@ ;;; Copyright © 2023 Janneke Nieuwenhuizen ;;; Copyright © 2023 Zheng Junjie <873216071@qq.com> ;;; Copyright © 2023 Foundation Devices, Inc. +;;; Copyright © 2024 Herman Rimm ;;; ;;; This file is part of GNU Guix. ;;; @@ -38,6 +39,7 @@ (define-module (guix utils) #:use-module (guix config) + #:autoload (guix read-print) (object->string*) #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) #:use-module (srfi srfi-26) @@ -145,6 +147,7 @@ go-to-location edit-expression delete-expression + insert-expression filtered-port decompressed-port @@ -502,6 +505,14 @@ the trailing line is included in the edited expression." "Delete the expression specified by SOURCE-PROPERTIES." (edit-expression source-properties (const "") #:include-trailing-newline? #t)) +(define (insert-expression source-properties expr) + "Insert EXPR before the top-level expression specified by +SOURCE-PROPERTIES." + (let* ((expr (object->string* expr 0)) + (insert (lambda (str) + (string-append expr "\n\n" str)))) + (edit-expression source-properties insert))) + ;;; ;;; Keyword arguments. -- cgit v1.2.3 From 50e514c1bc674b1c36344407c8c4b418d17759c5 Mon Sep 17 00:00:00 2001 From: Herman Rimm Date: Tue, 20 Feb 2024 21:45:12 +0100 Subject: utils: Add find-definition-insertion-location procedure. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * guix/utils.scm (find-definition-insertion-location): Add and export procedure. * tests/utils.scm ("find-definition-insertion-location"): Add test. Change-Id: Ie17e1b4a94790f58518ce121411a38d357f49feb Signed-off-by: Ludovic Courtès --- guix/utils.scm | 19 +++++++++++++++++++ 1 file changed, 19 insertions(+) (limited to 'guix') diff --git a/guix/utils.scm b/guix/utils.scm index 94b4d753d0..29ad09d9f7 100644 --- a/guix/utils.scm +++ b/guix/utils.scm @@ -148,6 +148,7 @@ edit-expression delete-expression insert-expression + find-definition-insertion-location filtered-port decompressed-port @@ -513,6 +514,24 @@ SOURCE-PROPERTIES." (string-append expr "\n\n" str)))) (edit-expression source-properties insert))) +(define (find-definition-insertion-location file term) + "Search in FILE for a top-level public definition whose defined term +alphabetically succeeds TERM. Return the location if found, or #f +otherwise." + (let ((search-term (symbol->string term))) + (call-with-input-file file + (lambda (port) + (do ((syntax (read-syntax port) + (read-syntax port))) + ((match (syntax->datum syntax) + (('define-public current-term _ ...) + (string> (symbol->string current-term) + search-term)) + ((? eof-object?) #t) + (_ #f)) + (and (not (eof-object? syntax)) + (syntax-source syntax)))))))) + ;;; ;;; Keyword arguments. -- cgit v1.2.3 From 635af8628c096526e3a79348f484e641aa05f04a Mon Sep 17 00:00:00 2001 From: Herman Rimm Date: Tue, 20 Feb 2024 21:45:13 +0100 Subject: import: Insert packages into modules alphabetically. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * guix/scripts/import.scm (guix-import): Add 'insert' option. (import-as-definitions): Add procedure. * doc/guix.texi (Invoking guix import): Describe 'insert' option. Change-Id: Id87ea707123630e12bcb6788599acac6895b26c4 Signed-off-by: Ludovic Courtès --- guix/scripts/import.scm | 82 ++++++++++++++++++++++++++++++++----------------- 1 file changed, 53 insertions(+), 29 deletions(-) (limited to 'guix') diff --git a/guix/scripts/import.scm b/guix/scripts/import.scm index 77fcfe3990..aca4e61f26 100644 --- a/guix/scripts/import.scm +++ b/guix/scripts/import.scm @@ -67,10 +67,39 @@ Run IMPORTER with ARGS.\n")) (display (G_ " -h, --help display this help and exit")) (display (G_ " + -i, --insert insert packages into file alphabetically")) + (display (G_ " -V, --version display version information and exit")) (newline) (show-bug-report-information)) +(define (import-as-definitions importer args proc) + "Wrap package expressions from IMPORTER with 'define-public and invoke +PROC callback." + (if (member importer importers) + (match (apply (resolve-importer importer) args) + ((and expr (or ('package _ ...) + ('let _ ...))) + (proc (package->definition expr))) + ((and expr ('define-public _ ...)) + (proc expr)) + ((expressions ...) + (for-each (lambda (expr) + (match expr + ((and expr (or ('package _ ...) + ('let _ ...))) + (proc (package->definition expr))) + ((and expr ('define-public _ ...)) + (proc expr)))) + expressions)) + (x + (leave (G_ "'~a' import failed~%") importer))) + (let ((hint (string-closest importer importers #:threshold 3))) + (report-error (G_ "~a: invalid importer~%") importer) + (when hint + (display-hint (G_ "Did you mean @code{~a}?~%") hint)) + (exit 1)))) + (define-command (guix-import . args) (category packaging) (synopsis "import a package definition from an external repository") @@ -84,33 +113,28 @@ Run IMPORTER with ARGS.\n")) (exit 0)) ((or ("-V") ("--version")) (show-version-and-exit "guix import")) + ((or ("-i" file importer args ...) + ("--insert" file importer args ...)) + (let ((find-and-insert + (lambda (expr) + (match expr + (('define-public term _ ...) + (let ((source-properties + (find-definition-insertion-location + file term))) + (if source-properties + (insert-expression source-properties expr) + (let ((port (open-file file "a"))) + (pretty-print-with-comments port expr) + (newline port) + (close-port port))))))))) + (import-as-definitions importer args find-and-insert))) ((importer args ...) - (if (member importer importers) - (let ((print (lambda (expr) - (leave-on-EPIPE - (pretty-print-with-comments (current-output-port) expr))))) - (match (apply (resolve-importer importer) args) - ((and expr (or ('package _ ...) - ('let _ ...))) - (print (package->definition expr))) - ((and expr ('define-public _ ...)) - (print expr)) - ((? list? expressions) - (for-each (lambda (expr) - (match expr - ((and expr (or ('package _ ...) - ('let _ ...))) - (print (package->definition expr))) - ((and expr ('define-public _ ...)) - (print expr))) - ;; Two newlines: one after the closing paren, and - ;; one to leave a blank line. - (newline) (newline)) - expressions)) - (x - (leave (G_ "'~a' import failed~%") importer)))) - (let ((hint (string-closest importer importers #:threshold 3))) - (report-error (G_ "~a: invalid importer~%") importer) - (when hint - (display-hint (G_ "Did you mean @code{~a}?~%") hint)) - (exit 1)))))) + (let ((print (lambda (expr) + (leave-on-EPIPE + (pretty-print-with-comments + (current-output-port) expr) + ;; Two newlines: one after the closing paren, and + ;; one to leave a blank line. + (newline) (newline))))) + (import-as-definitions importer args print))))) -- cgit v1.2.3 From df3e44cab1078ac6e84df9059a5acccdf9486700 Mon Sep 17 00:00:00 2001 From: Herman Rimm Date: Tue, 20 Feb 2024 21:45:14 +0100 Subject: import: Discard args after --version and --help. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * guix/scripts/import.scm (guix-import): Discard args. Change-Id: Icce5cd0daf9011f7ddde7904113b31b547f063ef Signed-off-by: Ludovic Courtès --- guix/scripts/import.scm | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/scripts/import.scm b/guix/scripts/import.scm index aca4e61f26..1f34cab088 100644 --- a/guix/scripts/import.scm +++ b/guix/scripts/import.scm @@ -108,10 +108,10 @@ PROC callback." (() (format (current-error-port) (G_ "guix import: missing importer name~%"))) - ((or ("-h") ("--help")) + ((or ("-h" _ ...) ("--help" _ ...)) (leave-on-EPIPE (show-help)) (exit 0)) - ((or ("-V") ("--version")) + ((or ("-V" _ ...) ("--version" _ ...)) (show-version-and-exit "guix import")) ((or ("-i" file importer args ...) ("--insert" file importer args ...)) -- cgit v1.2.3 From b386c11e7804e0b577411d930b60f1e0a4a0382c Mon Sep 17 00:00:00 2001 From: Herman Rimm Date: Tue, 20 Feb 2024 21:45:15 +0100 Subject: import: Do not return package name with json importer. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * guix/import/json.scm (json->code): Do not return package names after package expressions. * doc/package-hello.json: Fix comma errors and use valid greeter URL. Change-Id: Id71924e72f690a9bda5fbfdb65a443029adfd158 Signed-off-by: Ludovic Courtès --- guix/import/json.scm | 13 ++++++------- 1 file changed, 6 insertions(+), 7 deletions(-) (limited to 'guix') diff --git a/guix/import/json.scm b/guix/import/json.scm index b87e9918c5..bf346a1bef 100644 --- a/guix/import/json.scm +++ b/guix/import/json.scm @@ -78,14 +78,13 @@ a list of S-expressions, or return #F when the JSON is invalid." #:result (append result (list - (package->code (alist->package pkg names)) - (string->symbol (assoc-ref pkg "name")))))))) - (list #:names '() - #:result '()) - packages)))) + (package->code + (alist->package pkg names)))))))) + (list #:names '() + #:result '()) + packages)))) (package - (list (package->code (alist->package json)) - (string->symbol (assoc-ref json "name"))))))) + (list (package->code (alist->package json))))))) (const #f))) (define (json->scheme-file file) -- cgit v1.2.3